3a7987c · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Use StateT instead of IORef

3a7987cTom Smalley8 years ago

reflex-dom-core/src/Reflex/Dom/Builder/Hydration.hs+23−30

compare with develop

unifiedsplit

@@ -104,6 +104,7 @@ import Control.Monad.Exception

104import Control.Monad.Primitive

105import Control.Monad.Reader

106import Control.Monad.Ref

107+import Control.Monad.State

107#ifndef USE_TEMPLATE_HASKELL

108#ifndef USE_TEMPLATE_HASKELL

108import Data.Functor.Contravariant (phantom)

109import Data.Functor.Contravariant (phantom)

109#endif

110#endif

@@ -217,12 +218,11 @@ data HydrationDomBuilderEnv t m

217 , _hydrationDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it

218 , _hydrationDomBuilderEnv_commitAction :: !(JSM ()) -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it

218 , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode) -- In hydration mode?

219 , _hydrationDomBuilderEnv_hydrationMode :: {-# UNPACK #-} !(IORef HydrationMode) -- In hydration mode?

219 , _hydrationDomBuilderEnv_hydrationNode :: {-# UNPACK #-} !(IORef (Maybe Node)) -- Hydration node index

220 , _hydrationDomBuilderEnv_hydrationNode :: {-# UNPACK #-} !(IORef (Maybe Node)) -- Hydration node index

220− , _hydrationDomBuilderEnv_hydrationResult :: {-# UNPACK #-} !(IORef [Behavior t (m ())])

221 , _hydrationDomBuilderEnv_prerenderDepth :: {-# UNPACK #-} !(IORef Word)

222 , _hydrationDomBuilderEnv_eventChan :: {-# UNPACK #-} !(Chan [DSum (EventTriggerRef t) TriggerInvocation])

223 }

224

225−newtype HydrationDomBuilderT t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (RequesterT t JSM Identity (TriggerEventT t m)) a }

225+newtype HydrationDomBuilderT t m a = HydrationDomBuilderT { unHydrationDomBuilderT :: ReaderT (HydrationDomBuilderEnv t m) (StateT [Behavior t (m ())] (RequesterT t JSM Identity (TriggerEventT t m))) a }

226 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

227#if MIN_VERSION_base(4,9,1)

228 , MonadAsyncException

@@ -234,14 +234,17 @@ instance PrimMonad m => PrimMonad (HydrationDomBuilderT x m) where

234 primitive = lift . primitive

235

236instance MonadTrans (HydrationDomBuilderT t) where

237− lift = HydrationDomBuilderT . lift . lift . lift

237+ lift = HydrationDomBuilderT . lift . lift . lift . lift

238

239instance (Reflex t, MonadFix m) => DomRenderHook t (HydrationDomBuilderT t m) where

240 withRenderHook hook (HydrationDomBuilderT a) = do

241 e <- HydrationDomBuilderT ask

242− HydrationDomBuilderT $ lift $ withRequesting $ \rsp -> do

242+ s <- HydrationDomBuilderT get

243+ (a, s') <- HydrationDomBuilderT $ lift $ lift $ withRequesting $ \rsp -> do

243− (x, req) <- lift $ runRequesterT (runReaderT a e) $ runIdentity <$> rsp

244+ (x, req) <- lift $ runRequesterT (runStateT (runReaderT a e) s) $ runIdentity <$> rsp

244 return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)

245 return (ffor req $ \rm -> hook $ traverseRequesterData (\r -> Identity <$> r) rm, x)

246+ HydrationDomBuilderT $ put s'

247+ pure a

245 requestDomAction = HydrationDomBuilderT . lift . requestingIdentity

248 requestDomAction = HydrationDomBuilderT . lift . requestingIdentity

246 requestDomAction_ = HydrationDomBuilderT . lift . requesting_

249 requestDomAction_ = HydrationDomBuilderT . lift . requesting_

247

250

@@ -258,10 +261,10 @@ runHydrationDomBuilderT

258 => HydrationDomBuilderT t m a

261 => HydrationDomBuilderT t m a

259 -> HydrationDomBuilderEnv t m

262 -> HydrationDomBuilderEnv t m

260-- -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

263-- -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

261− -> m a

264+ -> m (a, [Behavior t (m ())])

262runHydrationDomBuilderT (HydrationDomBuilderT a) env =

265runHydrationDomBuilderT (HydrationDomBuilderT a) env =

263 flip runTriggerEventT (_hydrationDomBuilderEnv_eventChan env) $ do

266 flip runTriggerEventT (_hydrationDomBuilderEnv_eventChan env) $ do

264− rec (x, req) <- runRequesterT (runReaderT a env) rsp

267+ rec (x, req) <- runRequesterT (runStateT (runReaderT a env) []) rsp

265 rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $

268 rsp <- performEventAsync $ ffor req $ \rm f -> liftJSM $ runInAnimationFrame f $

266 traverseRequesterData (\r -> Identity <$> r) rm

269 traverseRequesterData (\r -> Identity <$> r) rm

267 return x

270 return x

@@ -280,7 +283,7 @@ askParent = HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_parent

280

283

281{-# INLINABLE askEvents #-}

284{-# INLINABLE askEvents #-}

282askEvents :: Monad m => HydrationDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

285askEvents :: Monad m => HydrationDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

283−askEvents = HydrationDomBuilderT . lift . lift $ TriggerEventT.askEvents

286+askEvents = HydrationDomBuilderT . lift . lift . lift $ TriggerEventT.askEvents

284

287

285localEnv :: Monad m => (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m a

288localEnv :: Monad m => (HydrationDomBuilderEnv t m -> HydrationDomBuilderEnv t m) -> HydrationDomBuilderT t m a -> HydrationDomBuilderT t m a

286localEnv f = HydrationDomBuilderT . local f . unHydrationDomBuilderT

289localEnv f = HydrationDomBuilderT . local f . unHydrationDomBuilderT

@@ -473,8 +476,7 @@ makeElement elementTag cfg child = do

473 let beh = pure $ void . flip runHydrationDomBuilderT env $ do

476 let beh = pure $ void . flip runHydrationDomBuilderT env $ do

474 es <- wrap events e $ extractRawElementConfig cfg

477 es <- wrap events e $ extractRawElementConfig cfg

475 liftIO $ fire es

478 liftIO $ fire es

476− hydrationResultRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationResult

479+ HydrationDomBuilderT $ modify (beh :)

477− liftIO $ modifyIORef' hydrationResultRef (beh :)

478 collapsed <- switchHold never $ ffor ese $ \es -> DMap.singleton (WrapArg Click) . Identity <$> (select es (WrapArg Click)) -- TODO! this can't stay here, obviously.

480 collapsed <- switchHold never $ ffor ese $ \es -> DMap.singleton (WrapArg Click) . Identity <$> (select es (WrapArg Click)) -- TODO! this can't stay here, obviously.

479 let evts = fan collapsed

481 let evts = fan collapsed

480 return ((Element evts (), result), e)

482 return ((Element evts (), result), e)

@@ -729,22 +731,19 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

729 HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

731 HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

730 unreadyChildren <- liftIO $ newIORef 0

732 unreadyChildren <- liftIO $ newIORef 0

731 hydrationNode <- liftIO $ newIORef Nothing

733 hydrationNode <- liftIO $ newIORef Nothing

732− r <- liftIO $ newIORef []

733− result <- runReaderT (unHydrationDomBuilderT a0) initialEnv

734+ (result, h') <- flip runStateT [] $ runReaderT (unHydrationDomBuilderT a0) initialEnv

734 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

735 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

735 , _hydrationDomBuilderEnv_commitAction = myCommitAction

736 , _hydrationDomBuilderEnv_commitAction = myCommitAction

736 , _hydrationDomBuilderEnv_hydrationNode = hydrationNode

737 , _hydrationDomBuilderEnv_hydrationNode = hydrationNode

737 , _hydrationDomBuilderEnv_parent = p

738 , _hydrationDomBuilderEnv_parent = p

738− , _hydrationDomBuilderEnv_hydrationResult = r

739 }

740− h' <- liftIO $ readIORef r

741 liftIO $ readIORef unreadyChildren >>= \case

740 liftIO $ readIORef unreadyChildren >>= \case

742 0 -> writeIORef haveEverBeenReady True

741 0 -> writeIORef haveEverBeenReady True

743 _ -> modifyIORef' parentUnreadyChildren succ

742 _ -> modifyIORef' parentUnreadyChildren succ

744 liftIO $ putStrLn "drawInitialChild: end"

743 liftIO $ putStrLn "drawInitialChild: end"

745 return (h', result)

744 return (h', result)

746 a'' <- numberOccurrences a'

745 a'' <- numberOccurrences a'

747− (result0, child') <- HydrationDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do

746+ (result0, child') <- HydrationDomBuilderT $ lift $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do

748 p <- liftIO (readIORef hydrating) >>= \case

747 p <- liftIO (readIORef hydrating) >>= \case

749 HydrationMode_Hydrating -> pure parent

748 HydrationMode_Hydrating -> pure parent

750 HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

749 HydrationMode_Immediate -> toNode <$> createDocumentFragment doc

@@ -758,17 +757,14 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

758 liftIO $ writeIORef currentCohort cohortId

757 liftIO $ writeIORef currentCohort cohortId

759 myCommitAction

758 myCommitAction

760 hydrationNode <- liftIO $ newIORef (Just $ toNode before)

759 hydrationNode <- liftIO $ newIORef (Just $ toNode before)

761− r <- liftIO $ newIORef []

762− result <- runReaderT (unHydrationDomBuilderT child) $ initialEnv

760+ (result, h') <- flip runStateT [] $ runReaderT (unHydrationDomBuilderT child) $ initialEnv

763 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

761 { _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

764 , _hydrationDomBuilderEnv_commitAction = commitAction

762 , _hydrationDomBuilderEnv_commitAction = commitAction

765 , _hydrationDomBuilderEnv_hydrationNode = hydrationNode

763 , _hydrationDomBuilderEnv_hydrationNode = hydrationNode

766 , _hydrationDomBuilderEnv_parent = p

764 , _hydrationDomBuilderEnv_parent = p

767− , _hydrationDomBuilderEnv_hydrationResult = r

768 }

765 }

769 uc <- liftIO $ readIORef unreadyChildren

766 uc <- liftIO $ readIORef unreadyChildren

770 h <- liftIO $ readIORef hydrating

767 h <- liftIO $ readIORef hydrating

771− h' <- liftIO $ readIORef r

772 let commitActionToRunNow = if uc == 0

768 let commitActionToRunNow = if uc == 0

773 then Just $ commitAction

769 then Just $ commitAction

774 else Nothing -- A child will run it when unreadyChildren is decremented to 0

770 else Nothing -- A child will run it when unreadyChildren is decremented to 0

@@ -776,13 +772,10 @@ instance (Reflex t, Adjustable t m, MonadJSM m, MonadHold t m, MonadFix m, PrimM

776 hydrationAction = if h == HydrationMode_Hydrating then Just h' else Nothing

772 hydrationAction = if h == HydrationMode_Hydrating then Just h' else Nothing

777 return (hydrationAction, commitActionToRunNow', result)

773 return (hydrationAction, commitActionToRunNow', result)

778 env <- HydrationDomBuilderT ask

774 env <- HydrationDomBuilderT ask

779− let f :: RequesterT t JSM Identity (TriggerEventT t m) x -> m ()

780− f = void . flip runHydrationDomBuilderT env . HydrationDomBuilderT . lift

781− g :: [Behavior t (m ())] -> Behavior t (m ())

775+ let f :: [Behavior t (m ())] -> Behavior t (m ())

782− g = fmap (void . sequence) . sequence

776+ f = fmap (void . sequence) . sequence

783− beh <- hold (g $ fst result0) (fmapMaybe (\(h,_,_) -> g <$> h) child')

777+ beh <- hold (f $ fst result0) (fmapMaybe (\(h,_,_) -> f <$> h) child')

784− hydrationResultRef <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_hydrationResult

778+ HydrationDomBuilderT $ modify (join beh :)

785− liftIO $ modifyIORef' hydrationResultRef (join beh :)

786 requestDomAction_ $ fmapMaybe (\(_,c,_) -> c) child'

779 requestDomAction_ $ fmapMaybe (\(_,c,_) -> c) child'

787 return (snd result0, fmap (\(_,_,r) -> r) child')

780 return (snd result0, fmap (\(_,_,r) -> r) child')

788

781

@@ -953,7 +946,7 @@ hoistTraverseIntMapWithKeyWithAdjust base updateChildUnreadiness applyDomUpdate_

953 liftIO $ writeIORef pendingChange (newUnready, p)

946 liftIO $ writeIORef pendingChange (newUnready, p)

954 when (IntMap.null newUnready) $ do

947 when (IntMap.null newUnready) $ do

955 applyDomUpdate p

948 applyDomUpdate p

956− (children0, children') <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'

949+ (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdateInt initialEnv markChildReady $ f k v) dm0 dm'

957 let processChild k (_, _, sRef, _) = do

950 let processChild k (_, _, sRef, _) = do

958 readIORef sRef >>= \case

951 readIORef sRef >>= \case

959 ChildReadyStateInt_Ready -> return Nothing

952 ChildReadyStateInt_Ready -> return Nothing

@@ -1043,7 +1036,7 @@ hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpda

1043 liftIO $ writeIORef pendingChange (newUnready, p)

1036 liftIO $ writeIORef pendingChange (newUnready, p)

1044 when (DMap.null newUnready) $ do

1037 when (DMap.null newUnready) $ do

1045 applyDomUpdate p

1038 applyDomUpdate p

1046− (children0, children') <- HydrationDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'

1039+ (children0, children') <- HydrationDomBuilderT $ lift $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'

1047 let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do

1040 let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do

1048 readIORef sRef >>= \case

1041 readIORef sRef >>= \case

1049 ChildReadyState_Ready -> return Nothing

1042 ChildReadyState_Ready -> return Nothing

@@ -1081,7 +1074,7 @@ drawChildUpdate initialEnv markReady child = do

1081 childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing

1074 childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing

1082 unreadyChildren <- liftIO $ newIORef 0

1075 unreadyChildren <- liftIO $ newIORef 0

1083 df <- createDocumentFragment $ _hydrationDomBuilderEnv_document initialEnv

1076 df <- createDocumentFragment $ _hydrationDomBuilderEnv_document initialEnv

1084− (placeholder, result) <- runReaderT (unHydrationDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

1077+ (placeholder, result) <- flip evalStateT [] $ runReaderT (unHydrationDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

1085 { _hydrationDomBuilderEnv_parent = toNode df

1078 { _hydrationDomBuilderEnv_parent = toNode df

1086 , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1079 , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1087 , _hydrationDomBuilderEnv_commitAction = markReady childReadyState

1080 , _hydrationDomBuilderEnv_commitAction = markReady childReadyState

@@ -1100,7 +1093,7 @@ drawChildUpdateInt initialEnv markReady child = do

1100 childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing

1093 childReadyState <- liftIO $ newIORef $ ChildReadyStateInt_Unready Nothing

1101 unreadyChildren <- liftIO $ newIORef 0

1094 unreadyChildren <- liftIO $ newIORef 0

1102 df <- createDocumentFragment $ _hydrationDomBuilderEnv_document initialEnv

1095 df <- createDocumentFragment $ _hydrationDomBuilderEnv_document initialEnv

1103− (placeholder, result) <- runReaderT (unHydrationDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

1096+ (placeholder, result) <- flip evalStateT [] $ runReaderT (unHydrationDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

1104 { _hydrationDomBuilderEnv_parent = toNode df

1097 { _hydrationDomBuilderEnv_parent = toNode df

1105 , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1098 , _hydrationDomBuilderEnv_unreadyChildren = unreadyChildren

1106 , _hydrationDomBuilderEnv_commitAction = markReady childReadyState

1099 , _hydrationDomBuilderEnv_commitAction = markReady childReadyState