module GHCJS.HPlay.Cell(Cell(..),boxCell,(.=),get,mkscell,scell, gcell, calc) where
import Transient.Base hiding((<**))
import Transient.Move
import qualified Transient.Internals as Internals
import GHCJS.HPlay.View
import Data.Typeable
import Unsafe.Coerce
import qualified Data.Map as M hiding ((!))
import System.IO.Unsafe
import Data.IORef
import Control.Monad.IO.Class
import Control.Monad
import Data.Maybe
import Control.Exception
import Data.List
import GHCJS.Perch
import Control.Exception
#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)}
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= getit id}
getit 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 getit) /= 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= typeOf (undefined :: 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
(.=) :: MonadIO m => Cell a -> a -> m ()
(.=) cell x = liftIO $ (setter cell ) x
get cell = Transient $ liftIO (getter cell)
infixr 0 .=
gcell :: JSString -> Widget Double
gcell n= Widget $ do
vars <- liftIO $ readIORef rvars
case M.lookup n vars of
Just exp -> inc n exp
Nothing -> error $ "cell not found: "++ show n
where
inc n exp= unsafePerformIO $ do
tries <- readIORef rtries
if tries <= maxtries
then do
writeIORef rtries (tries+1)
return exp
else throw Loop
data Loop= Loop deriving (Show,Typeable)
instance Exception Loop
type Expr a = TransIO a
rtries= unsafePerformIO $ newIORef $ (0::Int)
maxtries= 3 * (M.size $ unsafePerformIO $ readIORef rexprs)
rexprs :: IORef (M.Map JSString (Expr Double))
rexprs= unsafePerformIO $ newIORef M.empty
rvars :: IORef (M.Map JSString (Expr Double))
rvars= unsafePerformIO $ newIORef M.empty
rmodified :: IORef (M.Map JSString (Expr Double))
rmodified= unsafePerformIO $ newIORef M.empty
mkscell :: JSString -> Maybe Double -> Expr Double -> Widget Double
mkscell name val expr= mk (scell name expr) val
both mx= local $ runCloud mx Internals.<** runCloud ( atRemote mx)
scell :: JSString -> Expr Double -> Cell Double
scell id expr= Cell{ mk= \mv-> Widget $ runCloud $ do
both $ lliftIO $ do
exprs <- readIORef rexprs
writeIORef rexprs $ M.insert id expr exprs
r <- local $ norender $ getParam (Just id) "text" mv `fire` OnKeyUp
both $ lliftIO $ do
mod <- readIORef rmodified
writeIORef rmodified $ M.insert id (return r) mod
return r
, setter= \x -> withElem id $ \e -> setProp e "value" (toJSString $ show1 x)
, getter= getit id}
calc :: Widget ()
calc= Widget $ do
st <- getCont
liftIO $ handle (removeVar st) $ run' st $ do
nvs <- liftIO $ readIORef rmodified
when (not $ M.null nvs) $ do
values <- calc1
mapM_ (\(n,v) -> boxCell n .= v) values
liftIO $ writeIORef rmodified M.empty
where
run' st x= Internals.runTransState st x >> return ()
checktries x= unsafePerformIO $ do
n <- readIORef rtries
if (n> maxtries) then error "loop"
else writeIORef rtries $ n+1
calc1 :: TransIO [(JSString,Double)]
calc1= do
liftIO $ writeIORef rtries 0
cells <- liftIO $ readIORef rexprs
nvs <- liftIO $ readIORef rmodified
liftIO $ writeIORef rvars $ M.union nvs cells
solve
circular n= "loop detected in cell: "++ show n ++ " please fix the error"
removeVar st = \(e:: Loop) -> handle (removeVar st) $ do
nvs <- readIORef rmodified
exprs <- readIORef rexprs
case M.keys exprs \\ M.keys nvs of
[] -> do
error "no more input variables"
(name:_) -> do
mv <- getit name
case mv of
Nothing -> return ()
Just v -> do
writeIORef rmodified $ M.insert name ( return v) nvs
return ()
Internals.runTransState st (norender calc)
return ()
solve :: TransIO [(JSString,Double)]
solve = do
vars <- liftIO $ readIORef rvars
mapM (solve1 vars) $ M.toList vars
where
solve1 vars (k,f)= do
x <- f
liftIO $ writeIORef rvars $ M.insert k (return x) vars
return (k,x)
instance (Num a,Eq a,Fractional a) =>Fractional (Widget a)where
mf / mg = do
f <- mf
g <- mg
return $ f / g
fromRational = error "fromRational not implemented"
instance (Num a,Eq a) => Num (Widget a) where
fromInteger = return . fromInteger
f + g = f >>= \x -> g >>= \y -> return $ x + y
f * g = f >>= \x -> g >>= \y -> return $ x * y
negate f = f >>= return . negate
abs f = f >>= return . abs
signum f = f >>= return . signum