6e18982 · reflex · git.iko.soy

git.iko.soy/reflex

First try at builDynamic with PushM

commit6e1898251e37beae9300a04d06e2d72451f92795 authorOliver Batchelor <saulzar@gmail.com> dateWed 1 Aug 2018, 01:00 (8 years ago) parentb55c607

5 files changed+69−31

compare with develop

unifiedsplit

src/Reflex/Class.hs+23−11 src/Reflex/Dynamic.hs+14−10 src/Reflex/DynamicWriter/Base.hs+7−1 src/Reflex/Query/Base.hs+6−1 src/Reflex/Spider/Internal.hs+19−8

src/Reflex/Class.hs+23−11

@@ -61,6 +61,7 @@ module Reflex.Class

6161 , eitherToDSum

6262 , dsumToEither

6363 , factorEvent

64+ , filterEventKey

6465 -- ** Collapsing 'Event . Event'

6566 , switchHold

6667 , switchHoldPromptly

@@ -337,7 +338,7 @@ class MonadSample t m => MonadHold t m where

337338 holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)

338339 default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)

339340 holdIncremental v0 = lift . holdIncremental v0

340− buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)

341+ buildDynamic :: PushM t a -> Event t a -> m (Dynamic t a)

341342 {-

342343 default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)

343344 buildDynamic getV0 = lift . buildDynamic getV0

@@ -904,6 +905,24 @@ alignEventWithMaybe f ea eb =

904905 $ merge

905906 $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

906907

908+filterEventKey

909+ :: forall t m k v a.

910+ ( Reflex t

911+ , MonadFix m

912+ , MonadHold t m

913+ , GEq k

914+ )

915+ => k a

916+ -> Event t (DSum k v)

917+ -> m (Event t (v a))

918+filterEventKey k kv' = do

919+ let f :: DSum k v -> Maybe (v a)

920+ f (newK :=> newV) = case newK `geq` k of

921+ Just Refl -> Just newV

922+ Nothing -> Nothing

923+ takeWhileJustE f kv'

924+

925+

907926factorEvent

908927 :: forall t m k v a.

909928 ( Reflex t

@@ -916,20 +935,13 @@ factorEvent

916935 -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v))))

917936factorEvent k0 kv' = do

918937 key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv'

919− let inner :: forall m' b. (MonadFix m', MonadHold t m') => k b -> m' (Event t (v b))

920− inner k = do

921− let f :: DSum k v -> Maybe (v b)

922− f (newK :=> newV) = case newK `geq` k of

923− Just Refl -> Just newV

924− Nothing -> Nothing

925− takeWhileJustE f kv'

926− update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case

938+ let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case

927939 Some.This oldKey -> case newKey `geq` oldKey of

928940 Just Refl -> return Nothing

929941 Nothing -> do

930− newInner <- inner newKey

942+ newInner <- filterEventKey newKey kv'

931943 return $ Just $ newKey :=> Pair newVal (Compose newInner)

932− eInitial <- inner k0

944+ eInitial <- filterEventKey k0 kv'

933945 return (eInitial, update)

934946

935947--------------------------------------------------------------------------------

src/Reflex/Dynamic.hs+14−10

@@ -325,16 +325,20 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum

325325 LeftTag :=> Compose a -> Left $ coerceDynamic a

326326 RightTag :=> Compose b -> Right $ coerceDynamic b

327327

328−factorDyn :: forall t m k v. (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))

329−factorDyn d = do

330− k0 :=> v0 <- sample $ current d --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic

331− (initialEvent, update) <- factorEvent k0 $ updated d

332− initialD <- holdDyn v0 initialEvent

333− let f (k :=> Pair v (Compose v')) = do

334− d' <- holdDyn v v'

335− pure $ k :=> Compose d'

336− holdDyn (k0 :=> Compose initialD) $ pushAlwaysCheap f update

337−

328+factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k)

329+ => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))

330+factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where

331+ update :: Event t (DSum k (Compose (Dynamic t) v))

332+ update = flip push (updated d) $ \(newKey :=> newVal) -> do

333+ (oldKey :=> _) <- sample (current d)

334+ case newKey `geq` oldKey of

335+ Just Refl -> return Nothing

336+ Nothing -> Just <$> holdKey (newKey :=> newVal)

337+

338+ holdKey (k :=> v) = do

339+ inner' <- filterEventKey k (updated d)

340+ inner <- holdDyn v inner'

341+ return $ k :=> Compose inner

338342--------------------------------------------------------------------------------

339343-- Demux

340344--------------------------------------------------------------------------------

src/Reflex/DynamicWriter/Base.hs+7−1

@@ -9,6 +9,7 @@

99{-# LANGUAGE TupleSections #-}

1010{-# LANGUAGE TypeFamilies #-}

1111{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE StandaloneDeriving #-}

1213#ifdef USE_REFLEX_OPTIMIZER

1314{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

1415#endif

@@ -85,7 +86,12 @@ mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current)

8586 in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?

8687

8788-- | A basic implementation of 'MonadDynamicWriter'.

88−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) -- The list is kept in reverse order

89+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }

90+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order

91+

92+deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)

93+deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)

94+

8995

9096instance MonadRef m => MonadRef (DynamicWriterT t w m) where

9197 type Ref (DynamicWriterT t w m) = Ref m

src/Reflex/Query/Base.hs+6−1

@@ -8,6 +8,8 @@

88{-# LANGUAGE ScopedTypeVariables #-}

99{-# LANGUAGE TypeFamilies #-}

1010{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+

1113module Reflex.Query.Base

1214 ( QueryT (..)

1315 , runQueryT

@@ -50,7 +52,10 @@ import Reflex.Requester.Class

5052import Reflex.TriggerEvent.Class

5153

5254newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }

53− deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, MonadAtomicRef)

55+ deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef)

56+

57+deriving instance MonadHold t m => MonadHold t (QueryT t q m)

58+deriving instance MonadSample t m => MonadSample t (QueryT t q m)

5459

5560runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))

5661runQueryT (QueryT a) qr = do

src/Reflex/Spider/Internal.hs+19−8

@@ -1135,7 +1135,11 @@ instance HasSpiderTimeline x => Align (Event x) where

11351135 nil = eventNever

11361136 align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

11371137

1138−newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

1138+data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

1139+ | BuildDyn !(EventM x (PatchTarget p), Event x p)

1140+ | HoldDyn !(Hold x p)

1141+

1142+newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }

11391143

11401144newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

11411145newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

@@ -1156,15 +1160,15 @@ zipDynWith f da db =

11561160 return $ Just $ Identity $ f a b

11571161 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

11581162

1159−buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)

1163+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p)

11601164buildDynamic readV0 v' = do

1161− result <- liftIO $ newIORef $ Left (readV0, v')

1165+ result <- liftIO $ newIORef $ BuildDyn (readV0, v')

11621166 let !d = Dyn result

11631167 defer $ SomeDynInit d

11641168 return d

11651169

11661170unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1167−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1171+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x

11681172 where x = (readV0, v')

11691173

11701174-- ResultM can read behaviors and events

@@ -1374,14 +1378,21 @@ getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)

13741378getDynHold d = do

13751379 mh <- liftIO $ readIORef $ unDyn d

13761380 case mh of

1377− Right h -> return h

1378− Left (readV0, v') -> do

1381+ HoldDyn h -> return h

1382+ UnsafeDyn (readV0, v') -> do

13791383 holdInits <- getDeferralQueue

13801384 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

1385+ hold' v0 v'

1386+ BuildDyn (readV0, v') -> do

1387+ v0 <- liftIO $ runEventM readV0

1388+ hold' v0 v'

1389+ where

1390+ hold' v0 v' = do

13811391 h <- hold v0 v'

1382− liftIO $ writeIORef (unDyn d) $ Right h

1392+ liftIO $ writeIORef (unDyn d) $ HoldDyn h

13831393 return h

13841394

1395+

13851396-- Always refers to 0

13861397{-# NOINLINE zeroRef #-}

13871398zeroRef :: IORef Height

@@ -2317,7 +2328,7 @@ holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.S

23172328holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)

23182329holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

23192330

2320−buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

2331+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

23212332buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

23222333

23232334instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where