axiom-0.4.7: src/GHCJS/HPlay/Cell.hs
-----------------------------------------------------------------------------
--
-- 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