ghcjs-hplay 0.2 → 0.3
raw patch · 3 files changed
+307/−263 lines, 3 files
Files
- ghcjs-hplay.cabal +1/−1
- src/GHCJS/HPlay/Cell.hs +164/−95
- src/GHCJS/HPlay/View.hs +142/−167
ghcjs-hplay.cabal view
@@ -1,5 +1,5 @@ name: ghcjs-hplay -version: 0.2 +version: 0.3 cabal-version: >=1.10 build-type: Simple license: BSD3
src/GHCJS/HPlay/Cell.hs view
@@ -11,9 +11,12 @@ -- | -- ----------------------------------------------------------------------------- -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, CPP #-} -module GHCJS.HPlay.Cell where +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings, CPP, ScopedTypeVariables #-} +module GHCJS.HPlay.Cell(Cell(..),boxCell,(.=),get,mkscell,scell, gcell, calc) where import Transient.Base +import Transient.Move +import Transient.Internals (runTransState) + import GHCJS.HPlay.View import Data.Typeable import Unsafe.Coerce @@ -25,11 +28,17 @@ import Data.Maybe import Control.Exception import Data.List - import GHCJS.Perch +import Control.Exception #ifdef ghcjs_HOST_OS -import Data.JSString + +import Data.JSString hiding (empty) + +#else + +type JSString = String + #endif data Cell a = Cell { mk :: Maybe a -> Widget a @@ -41,38 +50,45 @@ --- a box cell with polimorphic value, identified by a string +-- | creates a input box cell with polimorphic value, identified by a string. +-- the cell can be updated programatically boxCell :: (Show a, Read a, Typeable a) => ElemID -> Cell a -boxCell id = Cell{ mk= \mv -> getParam id mv +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) + Just e -> setProp e "value" (toJSString $ 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 $ fromJSString 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 + , 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 + + + -- | Cell assignment (.=) :: MonadIO m => Cell a -> a -> m () (.=) cell x = liftIO $ (setter cell ) x @@ -113,11 +129,15 @@ -- 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 +-- | 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 -> TransIO Double +gcell n= do + vars <- liftIO $ readIORef rvars + case M.lookup n vars of Just exp -> inc n exp - Nothing -> error $ "cell error in: "++n + Nothing -> error $ "cell not found: "++ show n where inc n exp= unsafePerformIO $ do tries <- readIORef rtries @@ -126,113 +146,162 @@ writeIORef rtries (tries+1) return exp - else error n + else throw Loop +data Loop= Loop deriving (Show,Typeable) --- a parameter is a function of all of the rest parameters -type Expr a = M.Map JSString a -> a +instance Exception Loop +-- a parameter is a function of all of the rest +type Expr a = TransIO a + rtries= unsafePerformIO $ newIORef $ (0::Int) -maxtries= 3* (M.size $ unsafePerformIO $ readIORef rexprs) +maxtries= 3 * (M.size $ unsafePerformIO $ readIORef rexprs) -rexprs :: IORef (M.Map JSString (Expr Float)) -rexprs= unsafePerformIO $ newIORef M.empty +rexprs :: IORef (M.Map JSString (Expr Double)) +rexprs= unsafePerformIO $ newIORef M.empty -- initial expressions -rmodified :: IORef (M.Map JSString (Expr Float)) -rmodified= unsafePerformIO $ newIORef M.empty +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 +rmodified :: IORef (M.Map JSString (Expr 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 -> Maybe Double -> Expr Double -> TransIO Double mkscell name val expr= mk (scell name expr) val -scell id expr= Cell{ mk= \mv-> do - liftIO $ do +both mx= local $ runCloud mx <** runCloud ( atRemote $ mx) + +scell :: JSString -> Expr Double -> Cell Double +scell id expr= Cell{ mk= \mv-> runCloud $ do + both $ lliftIO $ do exprs <- readIORef rexprs writeIORef rexprs $ M.insert id expr exprs - r <- getParam id mv `fire` OnKeyUp - liftIO $ do - mod <- readIORef rmodified - writeIORef rmodified $ M.insert id (const r) mod + r <- local $ getParam (Just id) "text" mv `fire` OnKeyUp + + both $ lliftIO $ do + mod <- readIORef rmodified + writeIORef rmodified $ M.insert id (return r) mod return r - `continuePerch` id + -- `continuePerch` id - , setter= \x -> withElem id $ \e -> setProp e "value" (toJSString $ show1 x) + , setter= \x -> withElem id $ \e -> setProp e "value" (toJSString $ show1 x) - , getter= getit} - where + , getter= getit id} - getit= withElem id $ \e -> getProp e "value" >>= return . read1 - read1 s= if typeOf(typeIO getit) /= typeOf (undefined :: String) - then case readsPrec 0 $ fromJSString 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 + +-- | 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 :: TransIO () +calc= 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 +-- return () where - -- http://blog.sigfpe.com/2006/11/from-l-theorem-to-spreadsheet.html - -- loeb :: Functor f => f (t -> a) -> f a - loeb :: M.Map JSString (Expr a) -> M.Map JSString a - loeb x = fmap (\a -> a (loeb x)) x + run' st x= runTransState st x >> return () - calc1 :: IO [(JSString,Float)] + + checktries x= unsafePerformIO $ do + n <- readIORef rtries + if (n> maxtries) then error "loop" + else writeIORef rtries $ n+1 + + + calc1 :: TransIO [(JSString,Double)] calc1= do - writeIORef rtries 0 + liftIO $ writeIORef rtries 0 cells <- liftIO $ readIORef rexprs nvs <- liftIO $ readIORef rmodified - let mvalues = M.union nvs cells - evalues = loeb mvalues + liftIO $ writeIORef rvars $ M.union nvs cells + solve - toStrict $ M.toList evalues - toStrict xs = print xs >> return xs + circular n= "loop detected in cell: "++ show n ++ " please fix the error" - doit :: SomeException -> IO [(JSString,Float)] - doit e= do +-- removeVar :: EventF -> SomeException -> IO () -- [(JSString,Double)] + removeVar st = \(e:: Loop) -> handle (removeVar st) $ 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 $ toJSString err - error err + + error "no more input variables" (name:_) -> do - mv <- getter $ boxCell name + mv <- getit name + case mv of - Nothing -> return [] - Just v -> do - writeIORef rmodified $ M.insert name (const v) nvs - calc1 + Nothing -> return () + Just v -> do + writeIORef rmodified $ M.insert name ( return v) nvs + return () + runTransState st calc + return () + -- 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 -instance (Num a,Eq a,Fractional a) =>Fractional (x -> a)where - f / g = \x -> f x / g 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 + +--solve :: M.Map JSString (TransIO a) -> TransIO (M.Map JSString a) +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 (TransIO a)where + mf / mg = do + f <- mf + g <- mg + return $ f / g 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 .) +instance (Num a,Eq a) => Num (TransIO 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
src/GHCJS/HPlay/View.hs view
@@ -7,9 +7,10 @@ Widget, -- * running it -simpleWebApp, atServer, atRemote, runCloudIO -,runWidget,runWidgetId', runBody, addHeader, render, +module Transient.Move.Utils, + runBody, addHeader, render,runWidget', addSData, + -- * re-exported module Control.Applicative, @@ -54,16 +55,13 @@ ,FormInput(..), ElemID, elemById,withElem,getProp,setProp, alert, -fromJSString, toJSString +fromJSString, toJSString, getValue ) where - - - -import Transient.Base hiding (input,option,keep, keep') -import Transient.Internals(runTransient,onNothing,getCont,runCont,EventF(..),StateIO,RemoteStatus(..)) - +import Transient.Base hiding (input,option) +import Transient.Internals(runTransient,runClosure, runContinuation, getPrevId,onNothing,getCont,runCont,EventF(..),StateIO,RemoteStatus(..),IDNUM(..)) +import Transient.Move.Utils import Transient.Logged import Control.Applicative import Data.Monoid @@ -95,38 +93,27 @@ import Data.JSString as JS hiding (span,empty,strip) #else import Transient.Move hiding (pack,JSString) + import GHCJS.Perch hiding (eventName,JsEvent(..),option,JSVal) + #endif --- | executes the application in the server and the Web browser. --- the browser must point to http://hostname:port where port is the first parameter -simpleWebApp :: Integer -> Cloud x -> IO () -simpleWebApp port app= do - serverNode <- getWebServerNode port +#ifndef ghcjs_HOST_OS - let mynode = if isBrowserInstance - then createWebNode - else serverNode +type JSString = String - runCloudIO $ do - listen mynode - setData serverNode - app - return () +#endif --- | if invoked from the browser, run A computation in the web server and return to the browser -atServer :: Loggable a => Cloud a -> Cloud a -atServer proc= do - server <- onAll getSData <|> error "server not set, use 'setData serverNode'" - wormhole server $ atRemote proc --- | if invoked from the server or browwser, run the computation in the other node (need to be in a wormhole) -atRemote proc= do - teleport - r <- proc - teleport - return r +---- | if invoked from the browser, run A computation in the web server and return to the browser +--atServer :: Loggable a => Cloud a -> Cloud a +--atServer proc= do +-- server <- onAll getSData <|> error "server not set, use 'setData serverNode'" +-- runAt server proc + + + toJSString x= if typeOf x== typeOf (undefined :: String ) then pack $ unsafeCoerce x @@ -142,12 +129,20 @@ | otherwise = read $ unpack s -- !> "readunpack" getValue :: MonadIO m => Elem -> m (Maybe String) +getName :: MonadIO m => Elem -> m (Maybe String) #ifdef ghcjs_HOST_OS getValue e= liftIO $ do s <- getValueDOM e fromJSVal s -- return $ JS.unpack s + + + +getName e= liftIO $ do + s <- getNameDOM e + fromJSVal s #else getValue= undefined +getName= undefined #endif elemById :: MonadIO m => JSString -> m (Maybe Elem) @@ -253,12 +248,12 @@ getParam1 :: ( Typeable a, Read a, Show a) => JSString -> StateIO (ParamResult Perch a) getParam1 par = do - me <- elemById par -- !> ("looking for " ++ show par) + me <- elemById par -- !> ("looking for " ++ show par) case me of Nothing -> return NoParam Just e -> do v <- getValue e -- !!> ("exist" ++ show par) - readParam v -- !!> ("getParam for "++ show v) + readParam v -- !!> ("getParam for "++ show v) type Params= Attribs @@ -319,6 +314,7 @@ Prefix pre <- getData `onNothing` return (Prefix "") n <- genId return $ pre <> (toJSString $ {-'p': (show $ Prelude.length log)++-} ('n':show n)) +-- return $ (toJSString $ {-'p': (show $ Prelude.length log)++-} ('n':show n)) getPrev :: StateIO JSString getPrev= do @@ -338,7 +334,7 @@ --addPrefix= Transient $ do -- n <- genId -- Prefix s <- getData `onNothing` return ( Prefix "") --- setSData $ Prefix (toJSString( 's': show n)<> s) +-- setData $ Prefix (toJSString( 's': show n)<> s) -- return $ Just () @@ -382,7 +378,7 @@ -- | Display a password box getPassword :: TransIO String -getPassword = getParam "password" Nothing +getPassword = getParam Nothing "password" Nothing inputPassword :: TransIO String inputPassword= getPassword @@ -424,10 +420,10 @@ :: Monoid a => [TransIO (Radio a)] -> TransIO a getRadio ws = Transient $ do id <- genNewId - setSData $ RadioId id + setData $ RadioId id fs <- mapM runView ws let mx = mconcat fs - delSData $ RadioId id + delData $ RadioId id return $ fmap (\(Radio r) -> r) mx @@ -493,24 +489,26 @@ Show a, Read a) => Maybe a -> TransIO a -getTextBox ms = getParam "text" ms +getTextBox ms = getParam Nothing "text" ms getParam :: (Typeable a, Show a, Read a) => - JSString -> Maybe a -> TransIO a -getParam type1 mvalue= Transient $ getParamS type1 mvalue + Maybe JSString -> JSString -> Maybe a -> TransIO a +getParam look type1 mvalue= Transient $ getParamS look type1 mvalue -getParamS type1 mvalue= do - tolook <- genNewId +getParamS look type1 mvalue= do + tolook <- case look of + Nothing -> genNewId + Just n -> return n let nvalue x = case x of Nothing -> mempty Just v -> if (typeOf v== typeOf (undefined :: String)) then pack (unsafeCoerce v) - else if typeOf v== typeOf (undefined :: JSString) then unsafeCoerce v -- !!> "jsstring" + else if typeOf v== typeOf (undefined :: JSString) then unsafeCoerce v else toJSString $ show v -- !!> "show" setData HasElems @@ -519,7 +517,7 @@ case r of Validated x -> do addSData (finput tolook type1 (nvalue $ Just x) False Nothing :: Perch) ; return $ Just x -- !!> "validated" NotValidated s err -> do addSData (finput tolook type1 (toJSString s) False Nothing <> err :: Perch); return Nothing - NoParam -> do setSData WasParallel;addSData (finput tolook type1 (nvalue mvalue) False Nothing :: Perch); return Nothing + NoParam -> do setData WasParallel;addSData (finput tolook type1 (nvalue mvalue) False Nothing :: Perch); return Nothing @@ -534,7 +532,7 @@ case r of Validated x -> do addSData (ftextarea tolook $ toJSString x :: Perch); return $ Just x NotValidated s err -> do addSData (ftextarea tolook (toJSString s) :: Perch); return Nothing - NoParam -> do setSData WasParallel;addSData (ftextarea tolook $ toJSString nvalue :: Perch); return Nothing + NoParam -> do setData WasParallel;addSData (ftextarea tolook nvalue :: Perch); return Nothing where typef :: TransIO String -> StateIO (ParamResult Perch String) typef = undefined @@ -623,7 +621,7 @@ -- passive submit button. Submit a form, but it is not trigger any event. -- Unless you attach it with `raiseEvent` submitButton :: (Read a, Show a, Typeable a) => a -> TransIO a -submitButton label= getParam "submit" $ Just label +submitButton label= getParam Nothing "submit" $ Just label inputSubmit :: (Read a, Show a, Typeable a) => a -> TransIO a @@ -631,11 +629,12 @@ -- | active button. When clicked, return the first parameter wbutton :: a -> JSString -> Widget a -wbutton x label= - let label'= toJSString label in do - input ! atr "type" "submit" ! id label' ! atr "value" label `pass` OnClick +wbutton x label=Transient $ do + idn <- genNewId + runTrans $ do + input ! atr "type" "submit" ! id idn ! atr "value" label `pass` OnClick return x - `continuePerch` label' + `continuePerch` idn -- | when creating a complex widget with many tags, this call indentifies which tag will receive the attributes of the (!) operator. @@ -646,9 +645,13 @@ build f e' elemid eid - elemid id= elemById id >>= return . fromJust + elemid id= elemById id >>= return . fromJust +-- child e = do +-- jsval <- firstChild e +-- fromJSValUnchecked jsval + -- | Present a link. Return the first parameter when clicked wlink :: (Show a, Typeable a) => a -> Perch -> Widget a wlink x v= do @@ -679,10 +682,10 @@ -> TransIO a (<<<) v form= Transient $ do rest <- getData `onNothing` return noHtml - delSData rest + delData rest mx <- runView form f <- getData `onNothing` return noHtml - setSData $ rest <> v f + setData $ rest <> v f return mx @@ -704,9 +707,9 @@ -> Perch -> TransIO a (<++) form v= Transient $ do - mx <- runView form - addSData v - return mx + mx <- runView form + addSData v + return mx infixr 6 ++> infixr 6 <++ @@ -714,7 +717,7 @@ -- -- @bold << "enter name" ++> getString Nothing @ -- --- It has a infix prority: @infixr 6@ higuer that '<<<' and most other operators +-- It has a infix prority: @infixr 6@ higher that '<<<' and most other operators (++>) :: Perch -> TransIO a -> TransIO a html ++> w = Transient $ do @@ -730,7 +733,7 @@ infixl 8 <! widget <! attribs= Transient $ do rest <- getData `onNothing` return mempty - delSData rest + delData rest mx <- runView widget fs <- getData `onNothing` return mempty setData $ rest <> (fs `attrs` attribs :: Perch) @@ -738,9 +741,25 @@ instance Attributable (Widget a) where - (!) widget atrib = widget <! [atrib] - + (!) widget atrib = Transient $ do -- widget <! [atrib] + rest <- getData `onNothing` return (mempty:: Perch) + delData rest + mx <- runView widget + fs <- getData `onNothing` return (mempty :: Perch) + setData $ do rest ; (child $ mspan fs) ! atrib :: Perch + return mx + where + child render = Perch $ \e -> do + e' <- build render e + jsval <- firstChild e' + fromJSValUnchecked jsval +mspan cont= Perch $ \e -> do + n <- liftIO $ getName e +-- alert $ toJSString $ show n + if n == Just "EVENT" + then build cont e + else build (nelem "event" `child` cont) e -- | Empty widget that does not validate. May be used as \"empty boxes\" inside larger widgets. -- @@ -748,15 +767,9 @@ noWidget :: TransIO a noWidget= Control.Applicative.empty --- | a sinonym of noWidget that can be used in a monadic expression in the View monad. it stop the --- computation in the Widget monad. -stop :: TransIO a -stop= Control.Applicative.empty - - -- | Render raw view formatting. It is useful for displaying information. wraw :: Perch -> Widget () -wraw x= x ++> return () +wraw x= addSData x >> return () -- x ++> return () -- | wraw synonym rawHtml= wraw @@ -812,7 +825,7 @@ resetEventData :: TransIO () resetEventData= Transient $ do - setSData $ EventData "Onload" $ toDyn NoData + setData $ EventData "Onload" $ toDyn NoData return $ Just () -- !!> "RESETEVENTDATA" @@ -820,7 +833,7 @@ getEventData = getSData <|> return (EventData "Onload" $ toDyn NoData) -- (error "getEventData: event type not expected") setEventData :: EventData -> TransIO () -setEventData = setSData +setEventData = setData class IsEvent a where @@ -1009,59 +1022,21 @@ setDat elem action = do action -- !!> "begin action" return () -- !!> "end action" ---viewEffects :: Effects ---viewEffects x _ f= do --- id1 <- genNewId !!> "viewEffectsId" --- --- st <- get --- --- (t, mx) <- baseEffects x (strip st x) (\x -> runWidgetId' (f x) id1) --- --- return (\x -> (add id1 (span ! id id1) x ), mx) --- ---add id1 v form= do --- rest <- getData `onNothing` return noHtml --- delSData rest !!> show("added span", id1) --- mx <- form --- f <- getData `onNothing` return noHtml --- setSData $ rest <> v f --- setSData $ IdLine id1 --- return mx --- #ifdef ghcjs_HOST_OS ---foreign import javascript unsafe --- "var p=$1.parentNode;while ($1.nextSibling)p.removeChild($1.nextSibling);p.removeChild($1)" --- removeNextSibling :: Elem -> IO () --- #else ---removeNextSibling = undefined --- #endif - ---static mx= Transient $ do --- prev <- gets effects --- modify $ \ s-> s{effects= baseEffects} --- x <- runTrans mx --- modify $ \ s-> s{effects= unsafeCoerce prev} --- return x --- --- ---strip st x= Transient $ do ----- old <- getData `onNothing` return noHtml --- st' <- get --- put st'{mfSequence= mfSequence st} --- mx <- runView x --- put st' --- delSData noHtml --- return mx - addSData :: (MonadState EventF m,Typeable a ,Monoid a) => a -> m () addSData y= do x <- getData `onNothing` return mempty setData (x <> y) +newtype IdLine= IdLine JSString deriving(Read,Show) +data Repeat= Repeat | RepH JSString deriving (Eq, Read, Show) + + + -- | triggers the event that happens in a widget. The effects are the following: -- -- 1)The event reexecutes the monadic sentence where the widget is, (with no re-rendering) @@ -1076,19 +1051,26 @@ -- The part of the monadic expression that is before the event is not evaluated and his rendering is untouched. -- (but, at any moment, you can choose the element to be updated in the page using `at`) + + raiseEvent :: IsEvent event => Widget a -> event -> Widget a #ifdef ghcjs_HOST_OS raiseEvent w event = Transient $ do - cont <- get -- >>= \c -> return c{mfSequence= mfSequence c -1} + cont <- get let iohandler :: EventData -> IO () iohandler eventdata =do - runStateT (setSData eventdata >> runCont' cont) cont -- !!> "runCont INIT" + runStateT (setData eventdata >> runCont' cont) cont -- !!> "runCont INIT" return () -- !!> "runCont finished" - runView $ addEvent event iohandler <<< w + runView $ addEvent event iohandler <<< w -- return r where runCont' cont= do - setSData Repeat -- !!> "INITCLOSURE" + + mn <- getData + return () !> ("id mn",mn) + when (isJust mn) $ let IDNUM n = fromJust mn in modify $ \s -> s{mfSequence= n} + + setData Repeat -- !!> "INITCLOSURE" mr <- runClosure cont case mr of @@ -1098,7 +1080,7 @@ -- create an element and add any event handler to it. addEvent :: IsEvent a => a -> (EventData -> IO()) -> Perch -> Perch addEvent event iohandler be= Perch $ \e -> do - e' <- build (span ! atr "name" "event" $ be) e + e' <- build (mspan be) e buildHandler e' event iohandler return e -- jsval <- getChildren e @@ -1144,35 +1126,15 @@ continueIf b x = guard b >> return x ----- | executes a widget each t milliseconds until it validates and return () ---wtimeout :: Int -> Widget () -> Widget () ---wtimeout t w= Transient $ do --- id <- genNewId --- let f= do --- me <- elemById id --- case me of --- Nothing -> return () --- Just e ->do --- r <- clearChildren e >> runWidget w e --- case r of --- Nothing -> f --- Just () -> return () --- --- handler <- syncCallback ContinueAsync f --- --- let f= setTimeout t handler --- liftIO f --- FormElm f mx <- runView $ identified id w --- returnFormElm f mx --- + runWidgetId' :: Widget b -> ElemID -> TransIO b runWidgetId' ac id1= Transient runWidget1 where runWidget1 = do - me <- liftIO $ elemById id1 -- !!> ("RUNWIDGETID " ++ show id1) + me <- liftIO $ elemById id1 -- !> ("RUNWIDGETID", id1) case me of Just e -> do @@ -1182,7 +1144,7 @@ Nothing -> -- runTrans ac !!> ( "ID NOT FOUND " ++ show id) -- runTrans ac do - body <- liftIO getBody -- !!> ( "ID NOT FOUND " ++ show id1) + body <- liftIO getBody -- !> ( "ID NOT FOUND " ++ show id1) liftIO $ build (span ! id id1 $ noHtml) body runWidget1 @@ -1200,17 +1162,16 @@ runWidget' :: Widget b -> Elem -> TransIO b runWidget' action e = Transient $ do - mx <- runView action +-- liftIO $ clearChildren e -- !> "clear 0" + mx <- runView action -- !> "runVidget'" render <- getData `onNothing` (return noHtml) --- mr <- getData --- when (mr== Just Repeat) $ do --- delSData Repeat --- liftIO $ clearChildren e + liftIO $ build render e - delSData render + delData render return mx + -- | add a header in the <header> tag addHeader :: Perch -> IO () addHeader format= do @@ -1219,7 +1180,7 @@ return () --- | run the widget as the body of the HTML +-- | run the widget as the body of the HTML. It adds the rendering to the body of the document. runBody :: Widget a -> IO (Maybe a) runBody w= do body <- getBody @@ -1246,27 +1207,36 @@ -- onAll $ modify $ \s -> s{mfSequence= r} -- - +-- | executes the computation and add the effect of "hanging" the generated rendering from the one generated by the +-- previous `render` sentence, or from the body of the document, if there isn't any. If an event happens within +-- the `render` parameter, it deletes the rendering of all subsequent ones. +-- so that the sucessive sequence of `render` in the code will reconstruct them again. +-- However the rendering of elements combined with `<|>` or `<>` or `<*>` are independent. +-- This allows for full dynamic and composable client-side Web apps. render :: TransIO a -> TransIO a #ifdef ghcjs_HOST_OS render mx = do + id1 <- Transient $ do - me <- getData -- !!> "RENDER" - case me of - Just (IdLine id1) -> return $ Just id1 - Nothing -> Just <$> genNewId + me <- getData -- !> "RENDER" + case me of + Just (IdLine id1) -> return $ Just id1 + Nothing -> Just <$> genNewId id2 <- Transient $ Just <$> genNewId - runWidgetId' (mx' id1 id2 <++ (span ! id id2 $ noHtml)) id1 + n <- gets mfSequence + setData $ IDNUM n + setData $ IdLine id1 + runWidgetId' (mx' id2 <++ (span ! id id2 $ noHtml)) id1 + where - mx' id1 id2= do - setSData $ IdLine id1 - r <- mx + mx' id2= do + r <- mx -- !> "mx" addPrefix - (setSData $ IdLine id2) -- !!> show ("set",id2) + (setData $ IdLine id2) -- !!> show ("set",id2) do re <- getSData -- succed if is the result of an event @@ -1274,16 +1244,16 @@ Repeat -> do me <- liftIO $ elemById id2 case me of - Just e -> (liftIO $ clearChildren e) -- !> show ("clear1",id2) + Just e -> (liftIO $ clearChildren e) -- !> show ("clear1",id2) Nothing -> return () - setSData $ RepeatHandled id2 - delSData noHtml - RepeatHandled idx -> do + setData $ RepH id2 + delData noHtml + RepH idx -> do me <- liftIO $ elemById idx case me of - Just e -> (liftIO $ clearChildren e) -- !> show ("clear2",idx) + Just e -> (liftIO $ clearChildren e) -- !> show ("clear2",idx) Nothing -> return () - delSData Repeat + delData Repeat return r <|> return r -- !!> "NO DEL" @@ -1343,8 +1313,10 @@ foreign import javascript unsafe "$1[$2].toString()" getProp :: Elem -> JSString -> IO JSString -foreign import javascript unsafe "$1[$2]= $3" setProp :: Elem -> JSString -> JSString -> IO () + +foreign import javascript unsafe "$1[$2] = $3" setProp :: Elem -> JSString -> JSString -> IO () + foreign import javascript unsafe "alert($1)" alert :: JSString -> IO () @@ -1352,7 +1324,7 @@ foreign import javascript unsafe "document.getElementById($1)" elemByIdDOM :: JSString -> IO JSVal foreign import javascript unsafe "$1.value" getValueDOM :: Elem -> IO JSVal - +foreign import javascript unsafe "$1.tagName" getNameDOM :: Elem -> IO JSVal #else unpack= undefined getProp :: Elem -> JSString -> IO JSString @@ -1385,12 +1357,15 @@ #ifdef ghcjs_HOST_OS foreign import javascript unsafe "$1.childNodes" getChildren :: Elem -> IO JSVal +foreign import javascript unsafe "$1.firstChild" firstChild :: Elem -> IO JSVal foreign import javascript unsafe "$2.insertBefore($1, $3)" addChildBefore :: Elem -> Elem -> Elem -> IO() #else type JSVal = () getChildren :: Elem -> IO JSVal getChildren= undefined +firstChild :: Elem -> IO JSVal +firstChild= undefined addChildBefore :: Elem -> Elem -> Elem -> IO() addChildBefore= undefined #endif