git.iko.soy/reflex-dom
on develop help sign in
Merge remote-tracking branch 'origin/dynamic-writer' into fix-dyn-pattern-match

# Conflicts: # src/Reflex/Dom.hs # src/Reflex/Dom/Class.hs

commite88ead9bd6e0f99383446bb0b0e816cb44e23a5a authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 21 Nov 2015, 20:40 (11 years ago) parentaf398f191ee2e6
4 files changed+93−7
compare with develop
unifiedsplit
src/Reflex/Dom.hs+2 src/Reflex/Dom/Class.hs+18−3 src/Reflex/Dom/DynamicWriter.hs+70 src/Reflex/Dom/Widget/Basic.hs+3−4
src/Reflex/Dom.hs+2
@@ -5,6 +5,7 @@ module Reflex.Dom ( module Reflex
55 , module Reflex.Dom.Xhr
66 , module Reflex.Dom.Time
77 , module Reflex.Dom.WebSocket
8+ , module Reflex.Dom.DynamicWriter
89 ) where
910
1011import Reflex
@@ -14,3 +15,4 @@ import Reflex.Dom.Widget
1415import Reflex.Dom.Xhr
1516import Reflex.Dom.Time
1617import Reflex.Dom.WebSocket
18+import Reflex.Dom.DynamicWriter
src/Reflex/Dom/Class.hs+18−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)
@@ -39,13 +39,18 @@ class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger
3939 ) => MonadWidget t m | m -> t where
4040 type WidgetHost m :: * -> *
4141 type GuiAction m :: * -> *
42+ type WidgetOutput t m :: *
43+ type WidgetOutput t m = Event t (WidgetHost m ())
4244 askParent :: m Node
4345 subWidget :: Node -> m a -> m a
44− subWidgetWithVoidActions :: Node -> m a -> m (a, Event t (WidgetHost m ()))
46+ subWidgetWithVoidActions :: Node -> m a -> m (a, WidgetOutput t m)
4547 liftWidgetHost :: WidgetHost m a -> m a --TODO: Is this a good idea?
4648 schedulePostBuild :: WidgetHost m () -> m ()
4749 addVoidAction :: Event t (WidgetHost m ()) -> m ()
48− 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
4954
5055class Monad m => HasDocument m where
5156 askDocument :: m HTMLDocument
@@ -56,6 +61,9 @@ instance HasDocument m => HasDocument (ReaderT r m) where
5661instance HasDocument m => HasDocument (StateT r m) where
5762 askDocument = lift askDocument
5863
64+instance HasDocument m => HasDocument (Strict.StateT r m) where
65+ askDocument = lift askDocument
66+
5967-- | A singleton type for a given WebView; we use this to statically guarantee that different WebViews (and thus different javscript contexts) don't get mixed up
6068newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
6169
@@ -105,6 +113,11 @@ instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where
105113 askRunWithActions = lift askRunWithActions
106114 scheduleFollowup r a = lift $ scheduleFollowup r a
107115
116+instance HasPostGui t h m => HasPostGui t h (StateT s m) where
117+ askPostGui = lift askPostGui
118+ askRunWithActions = lift askRunWithActions
119+ scheduleFollowup r a = lift $ scheduleFollowup r a
120+
108121instance HasPostGui t h m => HasPostGui t h (Strict.StateT s m) where
109122 askPostGui = lift askPostGui
110123 askRunWithActions = lift askRunWithActions
@@ -113,6 +126,7 @@ instance HasPostGui t h m => HasPostGui t h (Strict.StateT s m) where
113126instance MonadWidget t m => MonadWidget t (ReaderT r m) where
114127 type WidgetHost (ReaderT r m) = WidgetHost m
115128 type GuiAction (ReaderT r m) = GuiAction m
129+ type WidgetOutput t (ReaderT r m) = WidgetOutput t m
116130 askParent = lift askParent
117131 subWidget n w = do
118132 r <- ask
@@ -129,6 +143,7 @@ instance MonadWidget t m => MonadWidget t (ReaderT r m) where
129143 return $ \rootElement w -> do
130144 (a, postBuild, voidActions) <- runWidget rootElement $ runReaderT w r
131145 return (a, postBuild, voidActions)
146+ tellWidgetOutput = lift . tellWidgetOutput
132147
133148performEvent_ :: MonadWidget t m => Event t (WidgetHost m ()) -> m ()
134149performEvent_ = addVoidAction
src/Reflex/Dom/DynamicWriter.hsnew file+70
@@ -0,0 +1,70 @@
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, HasDocument) -- The list is kept in reverse order
46+
47+instance HasWebView m => HasWebView (DynamicWriterT t w m) where
48+ type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
49+ askWebView = lift askWebView
50+
51+instance MonadRef m => MonadRef (DynamicWriterT t w m) where
52+ type Ref (DynamicWriterT t w m) = Ref m
53+ newRef = lift . newRef
54+ readRef = lift . readRef
55+ writeRef r = lift . writeRef r
56+
57+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
58+ newEventWithTrigger = lift . newEventWithTrigger
59+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
60+
61+deriving instance HasPostGui t h m => HasPostGui t h (DynamicWriterT t w m)
62+
63+runDynamicWriterT :: (Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
64+runDynamicWriterT (DynamicWriterT a) = do
65+ (result, ws) <- runStateT a []
66+ w <- mconcatDyn $ reverse ws
67+ return (result, w)
68+
69+tellDyn :: Monad m => Dynamic t w -> DynamicWriterT t w m ()
70+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