91ee2e6 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Add DynamicWriter

91ee2e6Ryan Trinkle11 years ago

src/Reflex/Dom.hs+2

compare with develop

unifiedsplit

@@ -4,6 +4,7 @@ module Reflex.Dom ( module Reflex

4 , module Reflex.Dom.Widget

5 , module Reflex.Dom.Xhr

6 , module Reflex.Dom.Time

7+ , module Reflex.Dom.DynamicWriter

7 ) where

8 ) where

9import Reflex

10import Reflex

@@ -12,3 +13,4 @@ import Reflex.Dom.Internal

12import Reflex.Dom.Widget

13import Reflex.Dom.Widget

13import Reflex.Dom.Xhr

14import Reflex.Dom.Xhr

14import Reflex.Dom.Time

15import 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 #-}

2module Reflex.Dom.Class where

4import Prelude hiding (mapM, mapM_, sequence, concat)

@@ -13,6 +13,7 @@ import Data.Foldable

13import Control.Monad.Ref

14import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence)

15import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)

16+import qualified Control.Monad.State.Strict as Strict hiding (mapM, mapM_, forM, forM_, sequence)

16import Data.Dependent.Sum (DSum (..))

17import Data.Dependent.Sum (DSum (..))

17import GHCJS.DOM.Types hiding (Event)

18import GHCJS.DOM.Types hiding (Event)

18import GHCJS.DOM (WebView)

19import GHCJS.DOM (WebView)

@@ -38,13 +39,18 @@ class ( Reflex t, MonadHold t m, MonadIO m, MonadAsyncException m, Functor m, Mo

38 ) => MonadWidget t m | m -> t where

39 ) => MonadWidget t m | m -> t where

39 type WidgetHost m :: * -> *

40 type WidgetHost m :: * -> *

40 type GuiAction m :: * -> *

41 type GuiAction m :: * -> *

42+ type WidgetOutput t m :: *

43+ type WidgetOutput t m = Event t (WidgetHost m ())

41 askParent :: m Node

44 askParent :: m Node

42 subWidget :: Node -> m a -> m a

45 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)

44 liftWidgetHost :: WidgetHost m a -> m a --TODO: Is this a good idea?

47 liftWidgetHost :: WidgetHost m a -> m a --TODO: Is this a good idea?

45 schedulePostBuild :: WidgetHost m () -> m ()

48 schedulePostBuild :: WidgetHost m () -> m ()

46 addVoidAction :: Event t (WidgetHost m ()) -> m ()

49 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

49class Monad m => HasDocument m where

55class Monad m => HasDocument m where

50 askDocument :: m HTMLDocument

56 askDocument :: m HTMLDocument

@@ -55,6 +61,9 @@ instance HasDocument m => HasDocument (ReaderT r m) where

55instance HasDocument m => HasDocument (StateT r m) where

61instance HasDocument m => HasDocument (StateT r m) where

56 askDocument = lift askDocument

62 askDocument = lift askDocument

64+instance HasDocument m => HasDocument (Strict.StateT r m) where

65+ askDocument = lift askDocument

66+

58class Monad m => HasWebView m where

67class Monad m => HasWebView m where

59 askWebView :: m WebView

68 askWebView :: m WebView

@@ -64,6 +73,9 @@ instance HasWebView m => HasWebView (ReaderT r m) where

64instance HasWebView m => HasWebView (StateT r m) where

73instance HasWebView m => HasWebView (StateT r m) where

65 askWebView = lift askWebView

74 askWebView = lift askWebView

76+instance HasWebView m => HasWebView (Strict.StateT r m) where

77+ askWebView = lift askWebView

78+

67newtype Restore m = Restore { restore :: forall a. m a -> IO a }

79newtype Restore m = Restore { restore :: forall a. m a -> IO a }

69class Monad m => MonadIORestore m where

81class Monad m => MonadIORestore m where

@@ -89,9 +101,18 @@ instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where

89 askPostGui = lift askPostGui

101 askPostGui = lift askPostGui

90 askRunWithActions = lift askRunWithActions

102 askRunWithActions = lift askRunWithActions

103

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+

92instance MonadWidget t m => MonadWidget t (ReaderT r m) where

112instance MonadWidget t m => MonadWidget t (ReaderT r m) where

93 type WidgetHost (ReaderT r m) = WidgetHost m

113 type WidgetHost (ReaderT r m) = WidgetHost m

94 type GuiAction (ReaderT r m) = GuiAction m

114 type GuiAction (ReaderT r m) = GuiAction m

115+ type WidgetOutput t (ReaderT r m) = WidgetOutput t m

95 askParent = lift askParent

116 askParent = lift askParent

96 subWidget n w = do

117 subWidget n w = do

97 r <- ask

118 r <- ask

@@ -108,6 +129,7 @@ instance MonadWidget t m => MonadWidget t (ReaderT r m) where

108 return $ \rootElement w -> do

129 return $ \rootElement w -> do

109 (a, postBuild, voidActions) <- runWidget rootElement $ runReaderT w r

130 (a, postBuild, voidActions) <- runWidget rootElement $ runReaderT w r

110 return (a, postBuild, voidActions)

131 return (a, postBuild, voidActions)

132+ tellWidgetOutput = lift . tellWidgetOutput

111

133

112performEvent_ :: MonadWidget t m => Event t (WidgetHost m ()) -> m ()

134performEvent_ :: MonadWidget t m => Event t (WidgetHost m ()) -> m ()

113performEvent_ = addVoidAction

135performEvent_ = 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

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

154 endPlaceholder <- text' ""

155 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef

156 performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack

157− childVoidAction <- hold childVoidAction0 $ fmap snd newChildBuilt

157+ childOutput <- holdDyn (Map.singleton () childVoidAction0) $ fmap (Map.singleton () . snd) newChildBuilt

158− addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?

158+ tellWidgetOutput childOutput

159 doc <- askDocument

160 runWidget <- getRunWidget

161 let build c = do

@@ -217,7 +217,6 @@ listHoldWithKey initialVals valsChanged mkChild = do

217 doc <- askDocument

218 endPlaceholder <- text' ""

219 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef

220−-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack

221 runWidget <- getRunWidget

220 runWidget <- getRunWidget

222 let buildChild df k v = runWidget df $ wrapChild k v

221 let buildChild df k v = runWidget df $ wrapChild k v

223 wrapChild k v = do

222 wrapChild k v = do

@@ -229,7 +228,7 @@ listHoldWithKey initialVals valsChanged mkChild = do

229 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

228 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

230 stateRef <- liftIO $ newIORef initialState

229 stateRef <- liftIO $ newIORef initialState

231 children <- holdDyn initialState newChildren

230 children <- holdDyn initialState newChildren

232− addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children

231+ tellWidgetOutput =<< mapDyn (fmap snd) children

233 mpOrig <- liftIO $ nodeGetParentNode endPlaceholder

232 mpOrig <- liftIO $ nodeGetParentNode endPlaceholder

234 forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)

233 forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)

235 addVoidAction $ flip fmap valsChanged $ \newVals -> do

234 addVoidAction $ flip fmap valsChanged $ \newVals -> do