content: -----------------------------------------------------------------------------
  --
  -- Module      :  Cell
  -- Copyright   :
  -- License     :  BSD3
  --
  -- Maintainer  :  agocorona@gmail.com
  -- Stability   :  experimental
  -- Portability :
  --
  -- |
  --
  -----------------------------------------------------------------------------
  {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
  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)}
  
  --instance Functor Cell where
  --  fmap f cell = cell{setter= \c x ->  c .= f x, getter = \cell -> get cell >>= return . f}
  
  
  -- a box cell with polimorphic value, identified by a string
  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
  
  
  
  
  
  -- | Cell assignment
  (.=) :: MonadIO m =>  Cell a -> a -> m ()
  (.=) cell x = liftIO $ (setter cell )  x
  
  get cell =  View $ liftIO $ getter cell >>= return . FormElm noHtml
  
  
  ---- |  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 ------
  
  
  -- | get a cell for the spreadsheet expression
  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
    -- http://blog.sigfpe.com/2006/11/from-l-theorem-to-spreadsheet.html
     -- loeb ::  Functor f => f (t -> a) -> f a
    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 .)
  