hplayground 0.1.2.2 → 0.1.2.3
raw patch · 3 files changed
+179/−112 lines, 3 files
Files
- hplayground.cabal +4/−4
- src/Haste/HPlay/Cell.hs +10/−13
- src/Haste/HPlay/View.hs +165/−95
hplayground.cabal view
@@ -1,5 +1,5 @@ name: hplayground -version: 0.1.2.2 +version: 0.1.2.3 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -8,10 +8,10 @@ stability: experimental homepage: https://github.com/agocorona/hplayground bug-reports: https://github.com/agocorona/hplayground/issues -synopsis: a client-side haskell framework that compiles to javascript with the haste compiler -description: Formlets with reactive effects in the client side. See homepage +synopsis: monadic, reactive Formlets running in the Web browser +description: client-side haskell framework that compiles to javascript with the haste compiler. See homepage category: Web -author: Alberto Gómez Corona +author: Alberto Gomez Corona data-dir: "" extra-source-files: src/Main.hs src/Main.html
src/Haste/HPlay/Cell.hs view
@@ -37,9 +37,17 @@ -- 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 -> withElem id $ \e -> setProp e "value" (show1 x) + , setter= \x -> do + me <- elemById id + case me of + Just e -> setProp e "value" (show1 x) + Nothing -> return () - , getter= getit} + , 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 @@ -161,17 +169,6 @@ then unsafeCoerce x else show x - - continuePerch :: Widget a -> ElemID -> Widget a - continuePerch w eid= View $ do - FormElm f mx <- runView w - return $ FormElm (c f) mx - where - c f =Perch $ \e' -> do - build f e' - elemid eid - - elemid id= elemById id >>= return . fromJust calc :: Widget ()
src/Haste/HPlay/View.hs view
@@ -14,7 +14,7 @@ {-# LANGUAGE FlexibleContexts, FlexibleInstances, ForeignFunctionInterface, CPP , TypeFamilies, DeriveDataTypeable, UndecidableInstances, ExistentialQuantification - , GADTs + , GADTs, MultiParamTypeClasses, FunctionalDependencies #-} module Haste.HPlay.View( Widget, @@ -47,7 +47,7 @@ ,delSessionData,delSData -- * reactive and events -,resetEventData,getEventData,EventData(..),EvData(..) +,resetEventData,getEventData, getMEventData, setIOEventData, setEventData, IsEvent(..), EventData(..),EvData(..) ,raiseEvent, fire, wake, react, pass ,continueIf, wtimeout, Event(..) @@ -61,7 +61,7 @@ ,ajax,Method(..) -- * low level and internals -,getNextId,genNewId +,getNextId,genNewId, continuePerch ,getParam, getCont,runCont ,FormInput(..) ,View(..),FormElm(..),EventF(..), MFlowState(..) @@ -88,6 +88,7 @@ import Prelude hiding(id,span) import Haste.Perch import Haste.Ajax +import Data.Dynamic --import Debug.Trace --(!>)= flip trace @@ -96,11 +97,14 @@ type SData= () -data EventF= forall b c.EventF (Widget b) [(b -> Widget c,ElemID)] +data EventF= forall b c.EventF (IO(Maybe b)) (b -> IO (Maybe c)) -data MFlowState= MFlowState { mfPrefix :: String,mfSequence :: Int - , needForm :: NeedForm, process :: EventF +data MFlowState= MFlowState { mfPrefix :: String + , mfSequence :: Int + , needForm :: NeedForm + , process :: EventF , fixed :: Bool + , lastEvent :: Dynamic , mfData :: M.Map TypeRep SData} type Widget a= View Perch IO a @@ -109,9 +113,12 @@ data FormElm view a = FormElm view (Maybe a) newtype View v m a = View { runView :: WState v m (FormElm v a)} -mFlowState0= MFlowState "" 0 NoElems (EventF empty - [(const $ empty,"noid") ] ) False M.empty +mFlowState0= MFlowState "" 0 NoElems (EventF (return Nothing) + (const (return Nothing)) ) False + (toDyn $toDyn $ EventData "OnLoad" NoData) + M.empty +noid= error "noId error" instance Functor (FormElm view ) where fmap f (FormElm form x)= FormElm form (fmap f x) @@ -146,15 +153,28 @@ put st' return $ FormElm mempty mx -setEventCont :: Widget a -> (a -> Widget b) -> String -> StateT MFlowState IO EventF +setEventCont :: Widget a -> (a -> Widget b) -> ElemID -> StateT MFlowState IO EventF setEventCont x f id= do st <- get let conf = process st case conf of - EventF x' fs -> do - let idx= strip st x - put st{process= EventF idx ((f,id): unsafeCoerce fs) } + EventF _ fs -> do + let idx= runWidgetId (strip st x) "noid" + put st{process= EventF idx ( \x -> runWidgetId ( f x) id `bind` unsafeCoerce fs) } return conf + where + at id w= View $ do + FormElm render mx <- (runView w) + return $ FormElm (set render) mx + where + set render= liftIO $ do + me <- elemById id + case me of + Nothing -> return () + Just e -> do + clearChildren e + build render e + return () resetEventCont cont= modify $ \s -> s {process= cont} @@ -173,14 +193,15 @@ Nothing -> return $ FormElm (form1 <> maybeSpan fix id1 noHtml) Nothing where - maybeSpan True id1 form2= form2 - maybeSpan False id1 form2= span ! id id1 $ form2 + maybeSpan True id1 form= form + maybeSpan False id1 form= span ! id id1 $ form return = View . return . FormElm mempty . Just fail msg= View . return $ FormElm (inred $ fromStr msg) Nothing + -- | To produce updates, each line of html produced by a "do" sequence in the Widget monad is included -- within a 'span' tag. When the line is reexecuted after a event, the span is updated with the new -- rendering. @@ -545,7 +566,8 @@ ( finput id "radio" str ( isJust strs ) Nothing `attrs` [("name",n)]) ret - +setRadioActive :: (Typeable a, Eq a, Show a) => + a -> String -> Widget (Radio a) setRadioActive rs x= setRadio rs x `raiseEvent` OnClick -- | encloses a set of Radio boxes. Return the option selected @@ -771,12 +793,26 @@ inputSubmit :: (Monad (View view m),StateType (View view m) ~ MFlowState,FormInput view, MonadIO m) => String -> View view m String inputSubmit= submitButton --- | active button. When clicked, return the label value +-- | active button. When clicked, return the first parameter wbutton :: a -> String -> Widget a wbutton x label= static $ do - input ! atr "type" "submit" ! atr "value" label `pass` OnClick + input ! atr "type" "submit" ! id label ! atr "value" label `pass` OnClick return x + `continuePerch` label +-- | when creating a complex widget with many tags, this call indentifies which tag will receive the attributes of the (!) operator. +continuePerch :: Widget a -> ElemID -> Widget a +continuePerch w eid= View $ do + FormElm f mx <- runView w + return $ FormElm (c f) mx + where + c f =Perch $ \e' -> do + build f e' + elemid eid + + elemid id= elemById id >>= return . fromJust + + -- | Present a link. Return the first parameter when clicked wlink :: (Show a, Typeable a) => a -> Perch -> Widget a wlink x v= static $ do @@ -982,17 +1018,86 @@ delSData= delSessionData --------------------------- -data EvData = NoData | Click Int (Int, Int) | Mouse (Int, Int) | Key Int deriving (Show,Eq) -data EventData= EventData{ evName :: String, evData :: EvData} deriving Show +data EvData = NoData | Click Int (Int, Int) | Mouse (Int, Int) | MouseOut | Key Int deriving (Show,Eq,Typeable) +data EventData= EventData{ evName :: String, evData :: EvData} deriving (Show,Typeable) -eventData= unsafePerformIO . newMVar $ EventData "OnLoad" NoData +--eventData :: MVar Dynamic +--eventData= unsafePerformIO . newMVar . toDyn $ EventData "OnLoad" NoData -resetEventData :: MonadIO m => m () -resetEventData= liftIO . modifyMVar_ eventData . const . return $ EventData "Onload" NoData +resetEventData :: (StateType m ~ MFlowState, MonadState m) => m () +resetEventData= modify $ \st -> st{ lastEvent= toDyn $ EventData "Onload" NoData} -getEventData :: MonadIO m => m EventData -getEventData= liftIO $ readMVar eventData +getEventData :: (Typeable a, StateType m ~ MFlowState, MonadState m) => m a +getEventData = gets lastEvent >>= return . (flip fromDyn) (error "getEventData: event type not expected") + +setEventData :: (Typeable a, StateType m ~ MFlowState, MonadState m) => a-> m () +setEventData dat= modify $ \st -> st{ lastEvent= toDyn dat} + +getMEventData :: (Typeable a, StateType m ~ MFlowState, MonadState m) => m (Maybe a) +getMEventData= gets lastEvent >>= return . fromDynamic + +setIOEventData :: Typeable a => a -> IO () +setIOEventData dat= do + st <- takeMVar globalState + putMVar globalState st{ lastEvent= toDyn dat} + + + +class IsEvent a b | a -> b where + eventName :: a -> String + buildHandler :: a -> IO () -> b + +instance IsEvent (Event m a) a where + eventName= evtName + + buildHandler event iohandler= + let nevent= eventName event + setDat :: EventData -> m () + setDat d= unsafeCoerce $ do + setIOEventData d + iohandler + + in case event of + OnLoad -> setDat (EventData nevent NoData) + OnUnload -> setDat (EventData nevent NoData) + OnChange -> setDat (EventData nevent NoData) + OnFocus -> setDat (EventData nevent NoData) + OnBlur -> setDat (EventData nevent NoData) + + OnMouseMove -> \(x,y) -> setDat $ EventData nevent $ Mouse(x,y) + + + OnMouseOver -> \(x,y) -> setDat $ EventData nevent $ Mouse(x,y) + + + OnMouseOut -> setDat $ EventData nevent $ MouseOut + + + OnClick -> \i (x,y) -> setDat $ EventData nevent $ Click i (x,y) + + + OnDblClick -> \i (x,y) -> setDat $ EventData nevent $ Click i (x,y) + + + OnMouseDown -> \i (x,y) -> setDat $ EventData nevent $ Click i (x,y) + + + OnMouseUp -> \i (x,y) -> setDat $ EventData nevent $ Click i (x,y) + + + OnKeyPress -> \i -> setDat $ EventData nevent $ Key i + + + OnKeyUp -> \i -> setDat $ EventData nevent $ Key i + + + OnKeyDown -> \i -> setDat $ EventData nevent $ Key i + + + + + -- | triggers the event when it happens in the widget. -- -- What happens then? @@ -1012,84 +1117,38 @@ -- monadic computations inside monadic computations are executed following recursively -- the steps mentioned above. So an event in a component deep down could or could not -- trigger the reexecution of the rest of the whole. -raiseEvent :: Widget a -> Event IO b ->Widget a +raiseEvent :: IsEvent event callback => Widget a -> event -> Widget a raiseEvent w event = View $ do cont <- getCont - FormElm render mx <- runView w - let proc = runCont cont -- runIt x (unsafeCoerce fs) >> return () - let nevent= evtName event :: String - let putevdata dat= modifyMVar_ eventData $ const $ return dat - let render' = case event of - OnLoad -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc - OnUnload -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc - OnChange -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc - OnFocus -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc - OnBlur -> addEvent (render :: Perch) event $ putevdata (EventData nevent NoData) >> proc - - OnMouseMove -> addEvent (render :: Perch) event $ \(x,y) -> do - putevdata $ EventData nevent $ Mouse(x,y) - proc - - OnMouseOver -> addEvent (render :: Perch) event $ \(x,y) -> do - putevdata $ EventData nevent $ Mouse(x,y) - proc - - OnMouseOut -> addEvent (render :: Perch) event proc - OnClick -> addEvent (render :: Perch) event $ \i (x,y) -> do - putevdata $ EventData nevent $ Click i (x,y) - proc - - OnDblClick -> addEvent (render :: Perch) event $ \i (x,y) -> do - putevdata $ EventData nevent $ Click i (x,y) - proc - - OnMouseDown -> addEvent (render :: Perch) event $ \i (x,y) -> do - putevdata $ EventData nevent $ Click i (x,y) - proc - - OnMouseUp -> addEvent (render :: Perch) event $ \i (x,y) -> do - putevdata $ EventData nevent $ Click i (x,y) - proc - - OnKeyPress -> addEvent (render :: Perch) event $ \i -> do - putevdata $ EventData nevent $ Key i - proc - - OnKeyUp -> addEvent (render :: Perch) event $ \i -> do - putevdata $ EventData nevent $ Key i - proc - - OnKeyDown -> addEvent (render :: Perch) event $ \i -> do - putevdata $ EventData nevent $ Key i - proc + let iohandler = runCont cont + nevent = eventName event + render' = addEvent' (render :: Perch) event iohandler return $ FormElm render' mx - - --- addEvent :: Perch -> Event IO a -> a -> Perch --- addEvent be event action= Perch $ \e -> do --- e' <- build be e --- onEvent e' event action --- return e' + where + -- | create an element and add any event handler to it. + -- This is a generalized version of addEvent + addEvent' :: IsEvent a b => Perch -> a -> IO() -> Perch + addEvent' be eevent iohandler= Perch $ \e -> do + e' <- build be e + let event= eventName eevent --- addto f f'= do --- mr <- f !> "addto1" --- case mr of --- Nothing -> return Nothing !> "addto1 nothing" --- Just x' -> f' x' !> "addto1just" + let hand = buildHandler eevent iohandler + listen e' event $ hand + return e' -- | A shorter synonym for `raiseEvent` -fire :: Widget a -> Event IO b ->Widget a +fire :: IsEvent event callback=> Widget a -> event -> Widget a fire = raiseEvent -- | A shorter and smoother synonym for `raiseEvent` -wake :: Widget a -> Event IO b -> Widget a +wake :: IsEvent event callback=> Widget a -> event -> Widget a wake = raiseEvent -- | A professional synonym for `raiseEvent` -react :: Widget a -> Event IO b -> Widget a +react :: IsEvent event callback=> Widget a -> event -> Widget a react = raiseEvent -- | pass trough only if the event is fired in this DOM element. @@ -1129,16 +1188,27 @@ getCont ::(StateType m ~ MFlowState, MonadState m) => m EventF getCont = gets process -runCont :: EventF -> IO () -runCont (EventF x fs)= do runIt x (unsafeCoerce fs); return () - where - runIt x fs= runBody $ x >>= compose fs +runCont :: EventF -> IO() +runCont (EventF x fs)= x `bind` fs >> return () - compose []= const empty - compose ((f,id): fs)= \x -> at id Insert (f x) >>= compose fs +bind :: IO (Maybe a) -> (a -> IO (Maybe b)) -> IO (Maybe b) +bind x f= do + mr <- x + case mr of + Just r -> f r + Nothing -> return Nothing +--bind x f = View $ do +-- FormElm form1 mk <- runView x +-- case mk of +-- Just k -> do +-- FormElm form2 mk <- runView $ f k +-- return $ FormElm (form1 <> form2) mk +-- Nothing -> +-- return $ FormElm form1 Nothing + globalState= unsafePerformIO $ newMVar mFlowState0 -- | run the widget as the content of a DOM element, the id is passed as parameter. All the @@ -1151,7 +1221,7 @@ clearChildren e runWidget ac e Nothing -> do - st <- takeMVar globalState + st <- unsafeCoerce $ takeMVar globalState (FormElm render mx, s) <- runStateT (runView ac) st liftIO $ putMVar globalState s return mx @@ -1254,7 +1324,7 @@ cb id cont rec= do responses <- readIORef responseAjax liftIO $ writeIORef responseAjax $ (id, rec):responses - runCont cont -- runIt x (unsafeCoerce fs) + runCont cont return ()