e88ead9 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge remote-tracking branch 'origin/dynamic-writer' into fix-dyn-pattern-match

e88ead9Ryan Trinkle11 years ago

src/Reflex/Dom.hs+2

compare with develop

unifiedsplit

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

5 , module Reflex.Dom.Xhr

6 , module Reflex.Dom.Time

7 , module Reflex.Dom.WebSocket

8+ , module Reflex.Dom.DynamicWriter

8 ) where

9 ) where

10import Reflex

11import Reflex

@@ -14,3 +15,4 @@ import Reflex.Dom.Widget

14import Reflex.Dom.Xhr

15import Reflex.Dom.Xhr

15import Reflex.Dom.Time

16import Reflex.Dom.Time

16import Reflex.Dom.WebSocket

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

2module Reflex.Dom.Class where

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

@@ -39,13 +39,18 @@ class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger

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

40 type WidgetHost m :: * -> *

41 type GuiAction m :: * -> *

42+ type WidgetOutput t m :: *

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

42 askParent :: m Node

44 askParent :: m Node

43 subWidget :: Node -> m a -> m a

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

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

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

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

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

49 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

50class Monad m => HasDocument m where

55class Monad m => HasDocument m where

51 askDocument :: m HTMLDocument

56 askDocument :: m HTMLDocument

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

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

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

57 askDocument = lift askDocument

62 askDocument = lift askDocument

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

65+ askDocument = lift askDocument

66+

59-- | 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

67-- | 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

60newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }

68newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }

@@ -105,6 +113,11 @@ instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where

105 askRunWithActions = lift askRunWithActions

113 askRunWithActions = lift askRunWithActions

106 scheduleFollowup r a = lift $ scheduleFollowup r a

114 scheduleFollowup r a = lift $ scheduleFollowup r a

107

115

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+

108instance HasPostGui t h m => HasPostGui t h (Strict.StateT s m) where

121instance HasPostGui t h m => HasPostGui t h (Strict.StateT s m) where

109 askPostGui = lift askPostGui

122 askPostGui = lift askPostGui

110 askRunWithActions = lift askRunWithActions

123 askRunWithActions = lift askRunWithActions

@@ -113,6 +126,7 @@ instance HasPostGui t h m => HasPostGui t h (Strict.StateT s m) where

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

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

114 type WidgetHost (ReaderT r m) = WidgetHost m

127 type WidgetHost (ReaderT r m) = WidgetHost m

115 type GuiAction (ReaderT r m) = GuiAction m

128 type GuiAction (ReaderT r m) = GuiAction m

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

116 askParent = lift askParent

130 askParent = lift askParent

117 subWidget n w = do

131 subWidget n w = do

118 r <- ask

132 r <- ask

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

129 return $ \rootElement w -> do

143 return $ \rootElement w -> do

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

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

131 return (a, postBuild, voidActions)

145 return (a, postBuild, voidActions)

146+ tellWidgetOutput = lift . tellWidgetOutput

132

147

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

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

134performEvent_ = addVoidAction

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

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

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