-----------------------------------------------------------------------------

--

-- 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