git.iko.soy/reflex-dom
on develop help sign in
Add DynamicWriter
commit91ee2e6e1552d17f73502c4200028f3e69ed9338 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 21 Nov 2015, 20:09 (11 years ago) parentc4ac902
4 files changed+96−7
compare with develop
unifiedsplit
src/Reflex/Dom.hs+2 src/Reflex/Dom/Class.hs+25−3 src/Reflex/Dom/DynamicWriter.hs+66 src/Reflex/Dom/Widget/Basic.hs+3−4
src/Reflex/Dom.hs+2
@@ -4,6 +4,7 @@ module Reflex.Dom ( module Reflex
44 , module Reflex.Dom.Widget
55 , module Reflex.Dom.Xhr
66 , module Reflex.Dom.Time
7+ , module Reflex.Dom.DynamicWriter
78 ) where
89
910import Reflex
@@ -12,3 +13,4 @@ import Reflex.Dom.Internal
1213import Reflex.Dom.Widget
1314import Reflex.Dom.Xhr
1415import Reflex.Dom.Time
16+import Reflex.Dom.DynamicWriter
src/Reflex/Dom/Class.hs+25−3
@@ -1,4 +1,4 @@
1−{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell, PolyKinds, TypeOperators, DeriveFunctor, LambdaCase, CPP, ForeignFunctionInterface, DeriveDataTypeable, ConstraintKinds #-}
1+{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell, PolyKinds, TypeOperators, DeriveFunctor, LambdaCase, CPP, ForeignFunctionInterface, DeriveDataTypeable, ConstraintKinds, DefaultSignatures #-}
22module Reflex.Dom.Class where
33
44import Prelude hiding (mapM, mapM_, sequence, concat)
@@ -13,6 +13,7 @@ import Data.Foldable
1313import Control.Monad.Ref
1414import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence)
1515import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)
16+import qualified Control.Monad.State.Strict as Strict hiding (mapM, mapM_, forM, forM_, sequence)
1617import Data.Dependent.Sum (DSum (..))
1718import GHCJS.DOM.Types hiding (Event)
1819import GHCJS.DOM (WebView)
@@ -38,13 +39,18 @@ class ( Reflex t, MonadHold t m, MonadIO m, MonadAsyncException m, Functor m, Mo
3839 ) => MonadWidget t m | m -> t where
3940 type WidgetHost m :: * -> *
4041 type GuiAction m :: * -> *
42+ type WidgetOutput t m :: *
43+ type WidgetOutput t m = Event t (WidgetHost m ())
4144 askParent :: m Node
4245 subWidget :: Node -> m a -> m a
43− subWidgetWithVoidActions :: Node -> m a -> m (a, Event t (WidgetHost m ()))
46+ subWidgetWithVoidActions :: Node -> m a -> m (a, WidgetOutput t m)
4447 liftWidgetHost :: WidgetHost m a -> m a --TODO: Is this a good idea?
4548 schedulePostBuild :: WidgetHost m () -> m ()
4649 addVoidAction :: Event t (WidgetHost m ()) -> m ()
47− getRunWidget :: IsNode n => m (n -> m a -> WidgetHost m (a, WidgetHost m (), Event t (WidgetHost m ())))
50+ getRunWidget :: IsNode n => m (n -> m a -> WidgetHost m (a, WidgetHost m (), WidgetOutput t m))
51+ tellWidgetOutput :: Ord k => Dynamic t (Map k (WidgetOutput t m)) -> m ()
52+ default tellWidgetOutput :: (WidgetOutput t m ~ Event t (WidgetHost m ()), Ord k) => Dynamic t (Map k (WidgetOutput t m)) -> m ()
53+ tellWidgetOutput = addVoidAction . switch . fmap (mergeWith (>>) . toList) . current
4854
4955class Monad m => HasDocument m where
5056 askDocument :: m HTMLDocument
@@ -55,6 +61,9 @@ instance HasDocument m => HasDocument (ReaderT r m) where
5561instance HasDocument m => HasDocument (StateT r m) where
5662 askDocument = lift askDocument
5763
64+instance HasDocument m => HasDocument (Strict.StateT r m) where
65+ askDocument = lift askDocument
66+
5867class Monad m => HasWebView m where
5968 askWebView :: m WebView
6069
@@ -64,6 +73,9 @@ instance HasWebView m => HasWebView (ReaderT r m) where
6473instance HasWebView m => HasWebView (StateT r m) where
6574 askWebView = lift askWebView
6675
76+instance HasWebView m => HasWebView (Strict.StateT r m) where
77+ askWebView = lift askWebView
78+
6779newtype Restore m = Restore { restore :: forall a. m a -> IO a }
6880
6981class Monad m => MonadIORestore m where
@@ -89,9 +101,18 @@ instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where
89101 askPostGui = lift askPostGui
90102 askRunWithActions = lift askRunWithActions
91103
104+instance HasPostGui t h m => HasPostGui t h (StateT r m) where
105+ askPostGui = lift askPostGui
106+ askRunWithActions = lift askRunWithActions
107+
108+instance HasPostGui t h m => HasPostGui t h (Strict.StateT r m) where
109+ askPostGui = lift askPostGui
110+ askRunWithActions = lift askRunWithActions
111+
92112instance MonadWidget t m => MonadWidget t (ReaderT r m) where
93113 type WidgetHost (ReaderT r m) = WidgetHost m
94114 type GuiAction (ReaderT r m) = GuiAction m
115+ type WidgetOutput t (ReaderT r m) = WidgetOutput t m
95116 askParent = lift askParent
96117 subWidget n w = do
97118 r <- ask
@@ -108,6 +129,7 @@ instance MonadWidget t m => MonadWidget t (ReaderT r m) where
108129 return $ \rootElement w -> do
109130 (a, postBuild, voidActions) <- runWidget rootElement $ runReaderT w r
110131 return (a, postBuild, voidActions)
132+ tellWidgetOutput = lift . tellWidgetOutput
111133
112134performEvent_ :: MonadWidget t m => Event t (WidgetHost m ()) -> m ()
113135performEvent_ = addVoidAction
src/Reflex/Dom/DynamicWriter.hsnew file+66
@@ -0,0 +1,66 @@
1+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving #-}
2+module Reflex.Dom.DynamicWriter where
3+
4+import Reflex
5+import Reflex.Host.Class
6+import Reflex.Dom.Class
7+import Control.Monad.IO.Class
8+import Control.Monad.State.Strict
9+import Control.Monad.Ref
10+import Control.Monad.Exception
11+import qualified Data.Map as Map
12+
13+instance MonadTrans (DynamicWriterT t w) where
14+ lift = DynamicWriterT . lift
15+
16+instance (MonadWidget t m, Monoid w) => MonadWidget t (DynamicWriterT t w m) where
17+ type WidgetHost (DynamicWriterT t w m) = WidgetHost m
18+ type GuiAction (DynamicWriterT t w m) = GuiAction m
19+ type WidgetOutput t (DynamicWriterT t w m) = (Dynamic t w, WidgetOutput t m)
20+ askParent = lift askParent
21+ subWidget n (DynamicWriterT child) = DynamicWriterT $ do
22+ ws <- get
23+ (result, ws') <- lift $ subWidget n $ runStateT child ws
24+ put ws'
25+ return result
26+ subWidgetWithVoidActions n (DynamicWriterT child) = DynamicWriterT $ do
27+ ((result, ws), v) <- lift $ subWidgetWithVoidActions n $ runStateT child []
28+ w <- mconcatDyn ws
29+ return (result, (w, v))
30+ liftWidgetHost = lift . liftWidgetHost
31+ schedulePostBuild = lift . schedulePostBuild
32+ addVoidAction = lift . addVoidAction
33+ getRunWidget = do
34+ runWidget <- lift getRunWidget
35+ return $ \n (DynamicWriterT child) -> do
36+ ((result, w), postBuild, o) <- runWidget n $ do
37+ (result, ws) <- runStateT child []
38+ w <- mconcatDyn ws
39+ return (result, w)
40+ return (result, postBuild, (w, o))
41+ tellWidgetOutput o = do
42+ tellDyn =<< mapDyn (mconcat . Map.elems) . joinDynThroughMap =<< mapDyn (fmap fst) o
43+ lift . tellWidgetOutput =<< mapDyn (fmap snd) o
44+
45+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException, HasWebView, HasDocument) -- The list is kept in reverse order
46+
47+instance MonadRef m => MonadRef (DynamicWriterT t w m) where
48+ type Ref (DynamicWriterT t w m) = Ref m
49+ newRef = lift . newRef
50+ readRef = lift . readRef
51+ writeRef r = lift . writeRef r
52+
53+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
54+ newEventWithTrigger = lift . newEventWithTrigger
55+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
56+
57+deriving instance HasPostGui t h m => HasPostGui t h (DynamicWriterT t w m)
58+
59+runDynamicWriterT :: (Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
60+runDynamicWriterT (DynamicWriterT a) = do
61+ (result, ws) <- runStateT a []
62+ w <- mconcatDyn $ reverse ws
63+ return (result, w)
64+
65+tellDyn :: Monad m => Dynamic t w -> DynamicWriterT t w m ()
66+tellDyn w = DynamicWriterT $ modify (w:)
src/Reflex/Dom/Widget/Basic.hs+3−4
@@ -154,8 +154,8 @@ widgetHoldInternal child0 newChild = do
154154 endPlaceholder <- text' ""
155155 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
156156 performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack
157− childVoidAction <- hold childVoidAction0 $ fmap snd newChildBuilt
158− addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?
157+ childOutput <- holdDyn (Map.singleton () childVoidAction0) $ fmap (Map.singleton () . snd) newChildBuilt
158+ tellWidgetOutput childOutput
159159 doc <- askDocument
160160 runWidget <- getRunWidget
161161 let build c = do
@@ -217,7 +217,6 @@ listHoldWithKey initialVals valsChanged mkChild = do
217217 doc <- askDocument
218218 endPlaceholder <- text' ""
219219 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
220−-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
221220 runWidget <- getRunWidget
222221 let buildChild df k v = runWidget df $ wrapChild k v
223222 wrapChild k v = do
@@ -229,7 +228,7 @@ listHoldWithKey initialVals valsChanged mkChild = do
229228 initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode dfOrig) $ wrapChild k v --Note: we have to use subWidgetWithVoidActions rather than runWidget here, because running post-build actions during build can cause not-yet-constructed values to be read
230229 stateRef <- liftIO $ newIORef initialState
231230 children <- holdDyn initialState newChildren
232− addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
231+ tellWidgetOutput =<< mapDyn (fmap snd) children
233232 mpOrig <- liftIO $ nodeGetParentNode endPlaceholder
234233 forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)
235234 addVoidAction $ flip fmap valsChanged $ \newVals -> do