content: -----------------------------------------------------------------------------
  --
  -- Module      :  Cell
  -- Copyright   :
  -- License     :  MIT
  --
  -- Maintainer  :  agocorona@gmail.com
  -- Stability   :  experimental
  -- Portability :
  --
  -- |
  --
  -----------------------------------------------------------------------------
  {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, CPP, ScopedTypeVariables #-}
  module GHCJS.HPlay.Cell(Cell(..),boxCell,bcell,(.=),get,mkscell,scell, gcell, calc)  where
  import Transient.Internals
  import Transient.Move --hiding (JSString)
  import GHCJS.HPlay.View
  import Data.Typeable
  import Unsafe.Coerce
  import qualified Data.Map as M hiding ((!))
  
  import Control.Monad.State hiding (get)
  import Control.Monad
  import Data.Monoid
  import Data.List
  import Control.Exception
  import Data.IORef
  import System.IO.Unsafe
  #ifdef ghcjs_HOST_OS
  
  import Data.JSString hiding (empty)
  
  #else
  
  -- type JSString = String
  
  #endif
  
  data Cell a  = Cell { mk :: Maybe a -> Widget a
                      , setter ::  a -> IO ()
                      , getter ::  IO (Maybe a)}
  
  --instance Functor Cell where
  --  fmap f cell = cell{setter= \c x ->  c .= f x, getter = \cell -> get cell >>= return . f}
  
  -- | creates (but not instantiates) an input box that has a setter and a getter. To instantiate it us his method `mk`
  bcell :: (Show a, Read a, Typeable a) =>TransIO (Cell a)
  bcell= genNewId >>= return . boxCell
  
  -- | creates (but not instantiates) a input box cell with polimorphic value, identified by a string.
  -- the cell has a getter and a setter. To instantiate it us his method `mk`
  boxCell :: (Show a, Read a, Typeable a) => ElemID -> Cell a
  boxCell id = Cell{ mk= \mv -> getParam  (Just id) "text" mv
                   , setter= \x -> do
                            me <- elemById id
                            case me of
                              Just e ->  setProp e "value" (toJSString $ show1 x)
                              Nothing -> return ()
  
                   , getter= getID id}
  
  getID id = withElem id $ \e -> do
    ms <- getValue e
    case ms of
      Nothing -> return Nothing
      Just s  -> return $ read1  s
    where
    read1 s=
        if typeOf(typeIO getID) /= typestring
             then case readsPrec 0  s  of
                 [(v,_)] -> v `seq` Just v
                 _       -> Nothing
             else Just $ unsafeCoerce s
  
  typeIO :: (ElemID -> IO (Maybe a)) -> a
  typeIO = undefined
  
  typestring :: TypeRep
  typestring= typeOf (undefined :: String)
  
  show1 :: (Show a, Typeable a) => a -> String
  show1 x= if typeOf x== typestring
          then unsafeCoerce x
          else show x
  
  instance Attributable (Cell a) where
   (Cell mk setter getter) ! atr = Cell (\ma -> mk ma ! atr) setter getter
  
  
  
  -- | Cell assignment using the cell setter
  (.=) :: MonadIO m =>  Cell a -> a -> m ()
  (.=) cell x = liftIO $ (setter cell )  x
  
  get cell =  Transient $ liftIO (getter cell)
  
  
  ---- |  a cell value assigned to other cell
  --(..=) :: Cell a -> Cell a -> Widget ()
  --(..=) cell cell'= get cell' >>= (cell .= )
  
  infixr 0 .=  -- , ..=
  
  -- experimental: to permit cell arithmetic
  
  --instance Num a => Num (Cell a) where
  --  c + c'= Cell undefined undefined  $
  --            do r1 <- getter c
  --               r2 <- getter c'
  --               return $  liftA2 (+) r1  r2
  --
  --  c * c'= Cell undefined undefined $
  --            do r1 <- getter c
  --               r2 <- getter c'
  --               return $ liftA2 (+) r1  r2
  --
  --  abs c= c{getter=  getter c >>= return . fmap abs}
  --
  --  signum c= c{getter=  getter c >>= return . fmap signum}
  --
  --  fromInteger i= Cell  undefined undefined  . return $ Just $ fromInteger i
  
  
  -- *  Spradsheet type cells
  -- Implement a solver that allows circular dependencies . See
  -- > http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
  
  -- The recursive Cell calculation DSL BELOW ------
  
  
  -- | within a `mkscell` formula, `gcell` get the the value of another cell using his name.
  --
  -- see http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
  gcell ::   JSString -> Cloud Double
  gcell n= loggedc $ do
    -- onAll $ do
    --    cutExceptions
    --    reportBack
    vars <- getCloudState rvars <|> return M.empty  -- liftIO $ readIORef rvars
    localIO  $ print ("gcell", n)
    case M.lookup n vars of
      Just exp -> do  inc ;  exp  !> "executing exp"
      Nothing -> error $ "cell not found: " ++ show n
    where
    inc  =  do
       Tries tries maxtries <- getCloudState rtries <|> error "no tries" --do
                                        -- Exprs exprs <- getCloudState
                                        -- return . Tries 0 $ 3 * (M.size $  exprs)
       localIO $ print tries
       if tries <= maxtries
         then  localIO $  writeIORef rtries $ Tries (tries+1) maxtries
         else  local $ do
           -- liftIO $ print "back"
           back Loop
  
  data Loop= Loop deriving (Show,Typeable)
  
  instance Exception Loop
  
  -- a parameter is a function of all of the rest
  type Expr a = Cloud a
  
  data Tries= Tries Int Int deriving Typeable
  rtries= unsafePerformIO $ newIORef $ Tries 0 0
  --maxtries=  3 * (M.size $ unsafePerformIO $ readIORef rexprs)
  
  -- newtype Exprs= Exprs (M.Map JSString (Expr Double))
  rexprs :: IORef (M.Map JSString (Expr Double))
  rexprs= unsafePerformIO $ newIORef M.empty      -- initial expressions
  
  -- newtype Vars= Vars (M.Map JSString (Expr Double))
  rvars :: IORef (M.Map JSString (Expr Double))
  rvars= unsafePerformIO $ newIORef M.empty       -- expressions actually used for each cell.
                                                  -- initially, A mix of reexprs and rmodified
                                                  -- and also contains the result of calculation
  
  -- newtype Modified= Modified (M.Map JSString (Expr Double)) deriving Typeable
  rmodified :: IORef (M.Map JSString ( Double))
  rmodified= unsafePerformIO $ newIORef M.empty    -- cells modified by the user or by the loop detection mechanism
  
  
  -- | make a spreadsheet cell. a spreadsheet cell is an input-output box that takes input values from
  -- the user, has an expression associated and display the result value after executing `calc`
  --
  -- see http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
  mkscell :: JSString -> Expr Double -> Cloud (Cell Double)
  mkscell  name  expr= do
    exprs <- onAll $ liftIO (readIORef rexprs) <|> return ( M.empty) -- readIORef rexprs
    onAll $ liftIO $ writeIORef  rexprs $ M.insert name expr exprs
    return $ scell name expr
  
  
  
  scell :: JSString -> Expr Double -> Cell Double
  scell id  expr= Cell{ mk= \mv -> Widget $  do
                             r <- norender $ getParam (Just id) "text"  mv `fire` OnChange
                             mod <-  liftIO (readIORef rmodified) <|> return( M.empty)
                             liftIO $ writeIORef rmodified $ M.insert id  r mod
                             return r
  
                      , setter= \x -> withElem id $ \e -> setProp e "value" (toJSString $ show1 x)
  
                      , getter= getID id}
  
  
  
  
  
  
  -- | executes the spreadsheet adjusting the vaules of the cells created with `mkscell` and solving loops
  --
  -- see http://tryplayg.herokuapp.com/try/spreadsheet.hs/edit
  calc :: Cloud ()
  calc=  do
    mod <- localIO $ readIORef rmodified
    onAll $ liftIO $ print ("LENGTH MOD", M.size mod)
    onAll $ liftIO $ print "setCloudState modified"
    setCloudState rmodified mod
    exprs <- getCloudState rexprs
    onAll $ liftIO $ print "setCloudState exprs"
    setCloudState rexprs exprs
    onAll $ liftIO $ print "setCloudState rvars"
  
    setCloudState rvars  M.empty
  
    onAll $ return() `onBack` (\(e::Loop) -> runCloud'  $ do localIO $ print "REMOVEVAR"; removeVar  e; local (forward Loop) )
    exprs <- getCloudState rexprs <|> error "no exprs"
    onAll $ liftIO $ print "setCloudState rtries"
  
    setCloudState rtries $ Tries 0 $ 3 * (M.size $  exprs)
    nvs <- getCloudState rmodified <|> error "no modified" -- liftIO $ readIORef rmodified
  
    onAll $ liftIO $ print ("LENGTH NVS", M.size nvs)
    when (not $ M.null nvs) $ calc1
              --values <-  calc1
              --localIO $ print "NEW CALC"
              --local $ mapM_ (\(n,v) -> boxCell n .= v)  values
    onAll $ liftIO $ print "setCloudState modified"
    setCloudState rmodified M.empty
  
    where
  
  
    --calc1  :: Expr [(JSString,Double)]
    calc1= do
        return () !> "CALC1"
        cells    <- getCloudState rexprs <|> error "no exprs" -- liftIO $ readIORef rexprs
        nvs      <- getCloudState rmodified <|> error "no modified2" -- liftIO $ readIORef rmodified
        onAll $ liftIO $ print "setCloudState vars"
  
        setCloudState rvars $ M.union (M.map return nvs) cells
  
        solve
  
    --solve :: Expr [(JSString,Double)]
    solve =  do
       vars <- getCloudState rvars <|> error "no vars" --  liftIO $ readIORef rvars
       onAll $ liftIO $ print $ ("LENGHT VARS", M.size vars)
       mapM_ (solve1 vars) $ M.toList vars
       where
       solve1 vars (k,f)= do
          localIO $ print ("solve1",k)
          x <- f
          localIO $ print ("setcloudstate var",k,x)
          local $ boxCell k .= x
          setCloudState rvars $ M.insert k (return x) vars
          return () -- (k,x) :: Expr (JSString,Double)
  
  
  setCloudState r v=  allNodes $  writeIORef r v
  getCloudState r= onAll . liftIO $ readIORef r
  
  --  removeVar ::SomeException -> IO () -- [(JSString,Double)]
  removeVar = \(e:: Loop) -> do
    nvs <- getCloudState rmodified <|>  error "no modified 3"-- readIORef rmodified
    -- mapM (\n -> snd n >>= \v ->  localIO $ print (fst n,v)) $ M.toList nvs
    exprs  <- getCloudState rexprs <|>  error " no Exprs2" --readIORef rexprs
  
    case  M.keys exprs \\ M.keys nvs of
      [] -> error "non solvable circularity in cell dependencies"
      (name:_) -> do
        localIO $ print ("removeVar",name)
  
        mv <- localIO $ getID name
  
        case mv of
            Nothing -> return ()
            Just v  -> do
                onAll $ liftIO $ print "setCloudState modified"
                setCloudState  rmodified  $ M.insert name v nvs
                return ()
  
  allNodes :: IO () -> Cloud ()
  allNodes mx= loggedc $ (localIO mx)  <> (atRemote $ (localIO $ print "UPDATE" >> mx))
  
  --atBrowser mx= if isBrowserInstance then mx else atRemote mx
  
  --atServer mx= if not isBrowserInstance then mx else atRemote mx
    
    -- http://blog.sigfpe.com/2006/11/from-l-theorem-to-spreadsheet.html
    -- loeb ::  Functor f => f (t -> a) -> f a
    --  loeb x = fmap (\a ->  a (loeb  x)) x
    -- loeb :: [([a]-> a)] -> [a]
    -- loeb x=  map (\f ->  f (loeb  x)) x
  
  --loeb :: [([a] -> IO a)] -> IO [a]
  --loeb x= mapM (\f -> loeb x >>= f) x -- fail does not terminate
  
  
  
  --loeb x=  map (\f ->  f (loeb  x)) x
  
  
  