6e18982 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

First try at builDynamic with PushM

6e18982Oliver Batchelor8 years ago

src/Reflex/Class.hs+23−11

compare with develop

unifiedsplit

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

61 , eitherToDSum

62 , dsumToEither

63 , factorEvent

64+ , filterEventKey

64 -- ** Collapsing 'Event . Event'

65 -- ** Collapsing 'Event . Event'

65 , switchHold

66 , switchHold

66 , switchHoldPromptly

67 , switchHoldPromptly

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

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

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

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

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

339 holdIncremental v0 = lift . holdIncremental v0

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

341 {-

342 {-

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

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

343 buildDynamic getV0 = lift . buildDynamic getV0

344 buildDynamic getV0 = lift . buildDynamic getV0

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

904 $ merge

905 $ merge

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

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

906

907

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+

907factorEvent

926factorEvent

908 :: forall t m k v a.

927 :: forall t m k v a.

909 ( Reflex t

928 ( Reflex t

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

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

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

917factorEvent k0 kv' = do

936factorEvent k0 kv' = do

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

937 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

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

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

928 Just Refl -> return Nothing

940 Just Refl -> return Nothing

929 Nothing -> do

941 Nothing -> do

930− newInner <- inner newKey

942+ newInner <- filterEventKey newKey kv'

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

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

932− eInitial <- inner k0

944+ eInitial <- filterEventKey k0 kv'

933 return (eInitial, update)

945 return (eInitial, update)

934

946

935--------------------------------------------------------------------------------

947--------------------------------------------------------------------------------

src/Reflex/Dynamic.hs+14−10

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

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

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

327

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

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+ => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))

329−factorDyn d = do

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

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

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

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

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

332− initialD <- holdDyn v0 initialEvent

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

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

334+ case newKey `geq` oldKey of

334− d' <- holdDyn v v'

335+ Just Refl -> return Nothing

335− pure $ k :=> Compose d'

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

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

337+

337−

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

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

340+ inner <- holdDyn v inner'

341+ return $ k :=> Compose inner

338--------------------------------------------------------------------------------

342--------------------------------------------------------------------------------

339-- Demux

343-- Demux

340--------------------------------------------------------------------------------

344--------------------------------------------------------------------------------

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

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

9{-# LANGUAGE TupleSections #-}

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE UndecidableInstances #-}

12+{-# LANGUAGE StandaloneDeriving #-}

12#ifdef USE_REFLEX_OPTIMIZER

13#ifdef USE_REFLEX_OPTIMIZER

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

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

14#endif

15#endif

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

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

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

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

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

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

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

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+

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

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

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

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

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

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

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE StandaloneDeriving #-}

12+

11module Reflex.Query.Base

13module Reflex.Query.Base

12 ( QueryT (..)

14 ( QueryT (..)

13 , runQueryT

15 , runQueryT

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

50import Reflex.TriggerEvent.Class

52import Reflex.TriggerEvent.Class

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

54newtype 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)

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

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

56runQueryT (QueryT a) qr = do

61runQueryT (QueryT a) qr = do

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

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

1135 nil = eventNever

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

1137

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+

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

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

1139

1143

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

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

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

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

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

1156 return $ Just $ Identity $ f a b

1160 return $ Just $ Identity $ f a b

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

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

1158

1162

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)

1160buildDynamic readV0 v' = do

1164buildDynamic readV0 v' = do

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

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

1162 let !d = Dyn result

1166 let !d = Dyn result

1163 defer $ SomeDynInit d

1167 defer $ SomeDynInit d

1164 return d

1168 return d

1165

1169

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

1170unsafeBuildDynamic :: 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

1168 where x = (readV0, v')

1172 where x = (readV0, v')

1169

1173

1170-- ResultM can read behaviors and events

1174-- ResultM can read behaviors and events

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

1374getDynHold d = do

1378getDynHold d = do

1375 mh <- liftIO $ readIORef $ unDyn d

1379 mh <- liftIO $ readIORef $ unDyn d

1376 case mh of

1380 case mh of

1377− Right h -> return h

1381+ HoldDyn h -> return h

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

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

1379 holdInits <- getDeferralQueue

1383 holdInits <- getDeferralQueue

1380 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

1384 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

1381 h <- hold v0 v'

1391 h <- hold v0 v'

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

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

1383 return h

1393 return h

1384

1394

1395+

1385-- Always refers to 0

1396-- Always refers to 0

1386{-# NOINLINE zeroRef #-}

1397{-# NOINLINE zeroRef #-}

1387zeroRef :: IORef Height

1398zeroRef :: IORef Height

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

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

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

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

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

2319

2330

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)

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

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

2322

2333

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

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