module Haste.HPlay.Cell where
import Haste.HPlay.View
import Control.Monad.IO.Class
import Haste
import Data.Typeable
import Unsafe.Coerce
import qualified Data.Map as M hiding ((!))
import System.IO.Unsafe
import Data.IORef
import Control.Monad
import Data.Maybe
import Control.Exception
import Data.List
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" (show1 x)
Nothing -> return ()
, getter= do
me <- elemById id
case me of
Nothing -> return Nothing
Just e -> getit}
where
getit= withElem id $ \e -> getProp e "value" >>= return . read1
read1 s= if typeOf(typeIO getit) /= typestring
then case readsPrec 0 s of
[(v,_)] -> Just v
_ -> Nothing
else Just $ unsafeCoerce s
typeIO :: IO(Maybe a) -> a
typestring= typeOf (undefined :: String)
typeIO = undefined
show1 x= if typeOf x== typestring
then unsafeCoerce x
else show x
(.=) :: MonadIO m => Cell a -> a -> m ()
(.=) cell x = liftIO $ (setter cell ) x
get cell = View $ liftIO $ getter cell >>= return . FormElm noHtml
infixr 0 .=
gcell :: Num a => String -> M.Map String a -> a
gcell n= \vars -> case M.lookup n vars of
Just exp -> inc n exp
Nothing -> error $ "cell error in: "++n
where
inc n exp= unsafePerformIO $ do
tries <- readIORef rtries
if tries <= maxtries
then do
writeIORef rtries (tries+1)
return exp
else error n
type Expr a = M.Map String a -> a
rtries= unsafePerformIO $ newIORef $ (0::Int)
maxtries= 3* (M.size $ unsafePerformIO $ readIORef rexprs)
rexprs :: IORef (M.Map String (Expr Float))
rexprs= unsafePerformIO $ newIORef M.empty
rmodified :: IORef (M.Map String (Expr Float))
rmodified= unsafePerformIO $ newIORef M.empty
mkscell name val expr= mk (scell name expr) val
scell id expr= Cell{ mk= \mv-> static $ do
liftIO $ do
exprs <- readIORef rexprs
writeIORef rexprs $ M.insert id expr exprs
r <- getParam (Just id) "text" mv `fire` OnKeyUp
liftIO $ do
mod <- readIORef rmodified
writeIORef rmodified $ M.insert id (const r) mod
return r
`continuePerch` id
, setter= \x -> withElem id $ \e -> setProp e "value" (show1 x)
, getter= getit}
where
getit= withElem id $ \e -> getProp e "value" >>= return . read1
read1 s= if typeOf(typeIO getit) /= typeOf (undefined :: String)
then case readsPrec 0 s of
[(v,_)] -> Just v
_ -> Nothing
else unsafeCoerce s
typeIO :: IO(Maybe a) -> a
typeIO = undefined
show1 x= if typeOf x== typeOf (undefined :: String)
then unsafeCoerce x
else show x
calc :: Widget ()
calc= do
nvs <- liftIO $ readIORef rmodified
when (not $ M.null nvs) $ do
values <-liftIO $ handle doit calc1
mapM_ (\(n,v) -> boxCell n .= v) values
liftIO $ writeIORef rmodified M.empty
where
loeb :: M.Map String (Expr a) -> M.Map String a
loeb x = fmap (\a -> a (loeb x)) x
calc1 :: IO [(String,Float)]
calc1=do
writeIORef rtries 0
cells <- liftIO $ readIORef rexprs
nvs <- liftIO $ readIORef rmodified
let mvalues = M.union nvs cells
evalues = loeb mvalues
toStrict $ M.toList evalues
toStrict xs = print xs >> return xs
circular n= "loop detected in cell: "++ n ++ " please fix the error"
doit :: SomeException -> IO [(String,Float)]
doit e= do
nvs <- readIORef rmodified
exprs <- readIORef rexprs
case M.keys exprs \\ M.keys nvs of
[] -> do
let Just (ErrorCall n)= fromException e
let err= circular n
alert err
error err
(name:_) -> do
mv <- getter $ boxCell name
case mv of
Nothing -> return []
Just v -> do
writeIORef rmodified $ M.insert name (const v) nvs
calc1
instance Show (Expr a)
instance Eq (Expr a)
instance (Num a,Eq a,Fractional a) =>Fractional (x -> a)where
f / g = \x -> f x / g x
fromRational = error "fromRational not implemented"
instance (Num a,Eq a) => Num (x -> a) where
fromInteger = const . fromInteger
f + g = \x -> f x + g x
f * g = \x -> f x * g x
negate = (negate .)
abs = (abs .)
signum = (signum .)