git.iko.soy/patch
on develop help sign in
Merge branch 'develop' into is-monoidal-containers-dep
commit95e0744c86c9e233cd4050b89196ec65fb7b4e0a authorLuigy Leon <luigy.leon@obsidian.systems> dateTue 13 Nov 2018, 04:35 (8 years ago) parent8217c812121f99
15 files changed+467−71
compare with develop
unifiedsplit
bench-cbits/checkCapability.c+6−6 reflex.cabal+3 src/Data/AppendMap.hs+4 src/Reflex.hs+2 src/Reflex/BehaviorWriter/Base.hs+204 src/Reflex/BehaviorWriter/Class.hs+26 src/Reflex/Class.hs+58 src/Reflex/DynamicWriter/Base.hs+5−1 src/Reflex/EventWriter/Base.hs+68−54 src/Reflex/FunctorMaybe.hs+10 src/Reflex/Optimizer.hs+5 src/Reflex/Query/Base.hs−7 src/Reflex/Query/Class.hs+23 test/EventWriterT.hs+52−3 test/Reflex/Test/CrossImpl.hs+1
bench-cbits/checkCapability.c+6−6
@@ -42,7 +42,7 @@ typedef struct Task_ {
4242 // or just continue immediately. It's a workaround for the fact
4343 // that signalling a condition variable doesn't do anything if the
4444 // thread is already running, but we want it to be sticky.
45− bool wakeup;
45+ HsBool wakeup;
4646#endif
4747
4848 // This points to the Capability that the Task "belongs" to. If
@@ -65,11 +65,11 @@ typedef struct Task_ {
6565 uint32_t n_spare_incalls;
6666 struct InCall_ *spare_incalls;
6767
68− bool worker; // == rtsTrue if this is a worker Task
69− bool stopped; // this task has stopped or exited Haskell
68+ HsBool worker; // == rtsTrue if this is a worker Task
69+ HsBool stopped; // this task has stopped or exited Haskell
7070
7171 // So that we can detect when a finalizer illegally calls back into Haskell
72− bool running_finalizers;
72+ HsBool running_finalizers;
7373
7474 // Links tasks on the returning_tasks queue of a Capability, and
7575 // on spare_workers.
@@ -98,12 +98,12 @@ struct Capability_ {
9898
9999 // true if this Capability is running Haskell code, used for
100100 // catching unsafe call-ins.
101− bool in_haskell;
101+ HsBool in_haskell;
102102
103103 // Has there been any activity on this Capability since the last GC?
104104 uint32_t idle;
105105
106− bool disabled;
106+ HsBool disabled;
107107
108108 // The run queue. The Task owning this Capability has exclusive
109109 // access to its run queue, so can wake up threads without
reflex.cabal+3
@@ -73,6 +73,8 @@ library
7373 Reflex,
7474 Reflex.Class,
7575 Reflex.Adjustable.Class,
76+ Reflex.BehaviorWriter.Base,
77+ Reflex.BehaviorWriter.Class,
7678 Reflex.Collection,
7779 Reflex.Dynamic,
7880 Reflex.Dynamic.Uniq,
@@ -208,6 +210,7 @@ test-suite EventWriterT
208210 build-depends: base
209211 , containers
210212 , deepseq >= 1.3 && < 1.5
213+ , dependent-map
211214 , dependent-sum
212215 , lens
213216 , mtl
src/Data/AppendMap.hs+4
@@ -26,7 +26,11 @@ import Prelude hiding (map, null)
2626import Data.Coerce
2727import Data.Default
2828import Data.Map (Map)
29+#if MIN_VERSION_containers(0,5,11)
2930import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith)
31+#else
32+import qualified Data.Map as Map (showTree, showTreeWith)
33+#endif
3034import Data.Map.Monoidal
3135import Reflex.Class (FunctorMaybe (..))
3236import Reflex.Patch (Additive, Group (..))
src/Reflex.hs+2
@@ -7,6 +7,8 @@ module Reflex
77
88import Reflex.Class as X
99import Reflex.Adjustable.Class as X
10+import Reflex.BehaviorWriter.Base as X
11+import Reflex.BehaviorWriter.Class as X
1012import Reflex.Collection as X
1113import Reflex.Dynamic as X
1214import Reflex.EventWriter.Base as X
src/Reflex/BehaviorWriter/Base.hsnew file+204
@@ -0,0 +1,204 @@
1+{-|
2+Module: Reflex.BehaviorWriter.Base
3+Description: Implementation of MonadBehaviorWriter
4+-}
5+{-# LANGUAGE CPP #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE LambdaCase #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
11+{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE UndecidableInstances #-}
16+{-# LANGUAGE StandaloneDeriving #-}
17+#ifdef USE_REFLEX_OPTIMIZER
18+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
19+#endif
20+module Reflex.BehaviorWriter.Base
21+ ( BehaviorWriterT (..)
22+ , runBehaviorWriterT
23+ , withBehaviorWriterT
24+ ) where
25+
26+import Control.Monad.Exception
27+import Control.Monad.Identity
28+import Control.Monad.IO.Class
29+import Control.Monad.Reader
30+import Control.Monad.Ref
31+import Control.Monad.State.Strict
32+import Data.Dependent.Map (DMap)
33+import qualified Data.Dependent.Map as DMap
34+import Data.Functor.Misc
35+import Data.IntMap (IntMap)
36+import qualified Data.IntMap as IntMap
37+import Data.Map (Map)
38+import qualified Data.Map as Map
39+import Data.Some (Some)
40+
41+import Reflex.Class
42+import Reflex.Adjustable.Class
43+import Reflex.BehaviorWriter.Class
44+import Reflex.Host.Class
45+import Reflex.PerformEvent.Class
46+import Reflex.PostBuild.Class
47+import Reflex.Query.Class
48+import Reflex.Requester.Class
49+import Reflex.TriggerEvent.Class
50+
51+-- | A basic implementation of 'MonadBehaviorWriter'.
52+newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }
53+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
54+
55+-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
56+-- along with the result of the action.
57+runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w)
58+runBehaviorWriterT (BehaviorWriterT a) = do
59+ (result, ws) <- runStateT a []
60+ return (result, mconcat $ reverse ws)
61+
62+-- | Map a function over the output of a 'BehaviorWriterT'.
63+withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)
64+ => (w -> w')
65+ -> BehaviorWriterT t w m a
66+ -> BehaviorWriterT t w' m a
67+withBehaviorWriterT f dw = do
68+ (r, d) <- lift $ do
69+ (r, d) <- runBehaviorWriterT dw
70+ let d' = fmap f d
71+ return (r, d')
72+ tellBehavior d
73+ return r
74+
75+deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)
76+deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)
77+
78+instance MonadTrans (BehaviorWriterT t w) where
79+ lift = BehaviorWriterT . lift
80+
81+instance MonadRef m => MonadRef (BehaviorWriterT t w m) where
82+ type Ref (BehaviorWriterT t w m) = Ref m
83+ newRef = lift . newRef
84+ readRef = lift . readRef
85+ writeRef r = lift . writeRef r
86+
87+instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where
88+ atomicModifyRef r = lift . atomicModifyRef r
89+
90+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where
91+ newEventWithTrigger = lift . newEventWithTrigger
92+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
93+
94+instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where
95+ tellBehavior w = BehaviorWriterT $ modify (w :)
96+
97+instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where
98+ ask = lift ask
99+ local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a
100+ reader = lift . reader
101+
102+instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where
103+ type Performable (BehaviorWriterT t w m) = Performable m
104+ performEvent_ = lift . performEvent_
105+ performEvent = lift . performEvent
106+
107+instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where
108+ newTriggerEvent = lift newTriggerEvent
109+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
110+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
111+
112+instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where
113+ getPostBuild = lift getPostBuild
114+
115+instance MonadState s m => MonadState s (BehaviorWriterT t w m) where
116+ get = lift get
117+ put = lift . put
118+
119+instance Requester t m => Requester t (BehaviorWriterT t w m) where
120+ type Request (BehaviorWriterT t w m) = Request m
121+ type Response (BehaviorWriterT t w m) = Response m
122+ requesting = lift . requesting
123+ requesting_ = lift . requesting_
124+
125+instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where
126+ tellQueryIncremental = lift . tellQueryIncremental
127+ askQueryResult = lift askQueryResult
128+ queryIncremental = lift . queryIncremental
129+
130+instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where
131+ runWithReplace a0 a' = do
132+ (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a'
133+ tellBehavior . join =<< hold (snd result0) (snd <$> result')
134+ return (fst result0, fst <$> result')
135+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust
136+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith
137+
138+traverseIntMapWithKeyWithAdjustImpl
139+ :: forall t w v' p p' v m.
140+ ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w)
141+ , Patch (p' (Behavior t w))
142+ , Monoid w
143+ , Reflex t
144+ , MonadHold t m
145+ , Functor p
146+ , p ~ p'
147+ )
148+ => ( (IntMap.Key -> v -> m (v', Behavior t w))
149+ -> IntMap v
150+ -> Event t (p v)
151+ -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))
152+ )
153+ -> (IntMap.Key -> v -> BehaviorWriterT t w m v')
154+ -> IntMap v
155+ -> Event t (p v)
156+ -> BehaviorWriterT t w m (IntMap v', Event t (p v'))
157+traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do
158+ (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'
159+ let liftedResult0 = fmap fst result0
160+ liftedResult' = fmap (fmap fst) result'
161+ liftedWritten0 :: IntMap (Behavior t w)
162+ liftedWritten0 = fmap snd result0
163+ liftedWritten' = fmap (fmap snd) result'
164+ i <- holdIncremental liftedWritten0 liftedWritten'
165+ tellBehavior $ pull $ do
166+ m <- sample $ currentIncremental i
167+ mconcat . IntMap.elems <$> traverse sample m
168+ return (liftedResult0, liftedResult')
169+
170+newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)
171+
172+traverseDMapWithKeyWithAdjustImpl
173+ :: forall t w k v' p p' v m.
174+ ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)
175+ , Patch (p' (Some k) (Behavior t w))
176+ , Monoid w
177+ , Reflex t
178+ , MonadHold t m
179+ )
180+ => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))
181+ -> DMap k v
182+ -> Event t (p k v)
183+ -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))
184+ )
185+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')
186+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))
187+ -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))
188+ -> DMap k v
189+ -> Event t (p k v)
190+ -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))
191+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do
192+ (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'
193+ let getValue (BehaviorWriterTLoweredResult (v, _)) = v
194+ getWritten (BehaviorWriterTLoweredResult (_, w)) = w
195+ liftedResult0 = DMap.map getValue result0
196+ liftedResult' = ffor result' $ mapPatch getValue
197+ liftedWritten0 :: Map (Some k) (Behavior t w)
198+ liftedWritten0 = weakenDMapWith getWritten result0
199+ liftedWritten' = ffor result' $ weakenPatchWith getWritten
200+ i <- holdIncremental liftedWritten0 liftedWritten'
201+ tellBehavior $ pull $ do
202+ m <- sample $ currentIncremental i
203+ mconcat . Map.elems <$> traverse sample m
204+ return (liftedResult0, liftedResult')
src/Reflex/BehaviorWriter/Class.hsnew file+26
@@ -0,0 +1,26 @@
1+{-|
2+Module: Reflex.BehaviorWriter.Class
3+Description: This module defines the 'MonadBehaviorWriter' class
4+-}
5+{-# LANGUAGE CPP #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+#ifdef USE_REFLEX_OPTIMIZER
11+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12+#endif
13+module Reflex.BehaviorWriter.Class
14+ ( MonadBehaviorWriter (..)
15+ ) where
16+
17+import Control.Monad.Reader (ReaderT, lift)
18+import Reflex.Class (Behavior)
19+
20+-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'
21+-- and combines them monoidally to provide a 'Behavior' result.
22+class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where
23+ tellBehavior :: Behavior t w -> m ()
24+
25+instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where
26+ tellBehavior = lift . tellBehavior
src/Reflex/Class.hs+58
@@ -44,9 +44,13 @@ module Reflex.Class
4444 -- ** Combining 'Event's
4545 , leftmost
4646 , mergeMap
47+ , mergeIntMap
4748 , mergeMapIncremental
4849 , mergeMapIncrementalWithMove
4950 , mergeIntMapIncremental
51+ , coincidencePatchMap
52+ , coincidencePatchMapWithMove
53+ , coincidencePatchIntMap
5054 , mergeList
5155 , mergeWith
5256 , difference
@@ -66,6 +70,7 @@ module Reflex.Class
6670 , switchHold
6771 , switchHoldPromptly
6872 , switchHoldPromptOnly
73+ , switchHoldPromptOnlyIncremental
6974 -- ** Using 'Event's to sample 'Behavior's
7075 , tag
7176 , tagMaybe
@@ -191,6 +196,7 @@ import Data.These
191196import Data.Type.Coercion
192197import Reflex.FunctorMaybe
193198import Reflex.Patch
199+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
194200
195201import Debug.Trace (trace)
196202
@@ -781,6 +787,10 @@ unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIn
781787mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
782788mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
783789
790+-- | Like 'mergeMap' but for 'IntMap'.
791+mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
792+mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap
793+
784794-- | Create a merge whose parents can change over time
785795mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)
786796mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)
@@ -859,6 +869,54 @@ switchHoldPromptOnly e0 e' = do
859869 eLag <- switch <$> hold e0 e'
860870 return $ coincidence $ leftmost [e', eLag <$ eLag]
861871
872+-- | When the given outer event fires, condense the inner events into the contained patch. Non-firing inner events will be replaced with deletions.
873+coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v)
874+coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case
875+ Nothing -> fmapCheap (const Nothing) e
876+ Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]
877+
878+-- | See 'coincicencePatchMap'
879+coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v)
880+coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case
881+ Nothing -> fmapCheap (const Nothing) e
882+ Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]
883+
884+-- | See 'coincicencePatchMap'
885+coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v)
886+coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of
887+ PatchMapWithMove.From_Delete -> fforCheap e $ \_ ->
888+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }
889+ PatchMapWithMove.From_Move k -> fforCheap e $ \_ ->
890+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Move k }
891+ PatchMapWithMove.From_Insert ev -> leftmost
892+ [ fforCheap ev $ \v ->
893+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Insert v }
894+ , fforCheap e $ \_ ->
895+ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }
896+ ]
897+
898+switchHoldPromptOnlyIncremental
899+ :: forall t m p pt w
900+ . ( Reflex t
901+ , MonadHold t m
902+ , Patch (p (Event t w))
903+ , PatchTarget (p (Event t w)) ~ pt (Event t w)
904+ , Patch (p w)
905+ , PatchTarget (p w) ~ pt w
906+ , Monoid (pt w)
907+ )
908+ => (Incremental t (p (Event t w)) -> Event t (pt w))
909+ -> (Event t (p (Event t w)) -> Event t (p w))
910+ -> pt (Event t w)
911+ -> Event t (p (Event t w))
912+ -> m (Event t (pt w))
913+switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = do
914+ lag <- mergePatchIncremental <$> holdIncremental e0 e'
915+ pure $ ffor (align lag (coincidencePatch e')) $ \case
916+ This old -> old
917+ That new -> new `applyAlways` mempty
918+ These old new -> new `applyAlways` old
919+
862920instance Reflex t => Align (Event t) where
863921 nil = never
864922 align = alignEventWithMaybe Just
src/Reflex/DynamicWriter/Base.hs+5−1
@@ -38,9 +38,10 @@ import Data.Semigroup
3838import Data.Some (Some)
3939import Data.These
4040
41−import Reflex.Class
4241import Reflex.Adjustable.Class
42+import Reflex.Class
4343import Reflex.DynamicWriter.Class
44+import Reflex.EventWriter.Class (EventWriter, tellEvent)
4445import Reflex.Host.Class
4546import qualified Reflex.Patch.MapWithMove as MapWithMove
4647import Reflex.PerformEvent.Class
@@ -226,3 +227,6 @@ instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) wh
226227 tellQueryIncremental = lift . tellQueryIncremental
227228 askQueryResult = lift askQueryResult
228229 queryIncremental = lift . queryIncremental
230+
231+instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where
232+ tellEvent = lift . tellEvent
src/Reflex/EventWriter/Base.hs+68−54
@@ -22,9 +22,10 @@ module Reflex.EventWriter.Base
2222 , withEventWriterT
2323 ) where
2424
25−import Reflex.Class
2625import Reflex.Adjustable.Class
26+import Reflex.Class
2727import Reflex.EventWriter.Class (EventWriter, tellEvent)
28+import Reflex.DynamicWriter.Class (MonadDynamicWriter, tellDyn)
2829import Reflex.Host.Class
2930import Reflex.PerformEvent.Class
3031import Reflex.PostBuild.Class
@@ -40,7 +41,6 @@ import Control.Monad.Ref
4041import Control.Monad.State.Strict
4142import Data.Dependent.Map (DMap, DSum (..))
4243import qualified Data.Dependent.Map as DMap
43−import Data.Foldable
4444import Data.Functor.Compose
4545import Data.Functor.Misc
4646import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
@@ -48,10 +48,11 @@ import Data.IntMap.Strict (IntMap)
4848import qualified Data.IntMap.Strict as IntMap
4949import Data.List.NonEmpty (NonEmpty (..))
5050import Data.Map (Map)
51+import qualified Data.Map as Map
5152import Data.Semigroup
5253import Data.Some (Some)
5354import Data.Tuple
54−import Data.Type.Equality
55+import Data.Type.Equality hiding (apply)
5556
5657import Unsafe.Coerce
5758
@@ -135,9 +136,9 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where
135136
136137instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
137138 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
138− traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
139− traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
140− traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
139+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap
140+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap
141+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove
141142
142143instance Requester t m => Requester t (EventWriterT t w m) where
143144 type Request (EventWriterT t w m) = Request m
@@ -160,19 +161,29 @@ runWithReplaceEventWriterTWith f a0 a' = do
160161 return (fst result0, fmapCheap fst result')
161162
162163-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
163−sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))
164− => ( (IntMap.Key -> v -> m (Event t w, v'))
165− -> IntMap v
166− -> Event t (p v)
167− -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
168− )
169− -> (p (Event t w) -> [Event t w])
170− -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
171− -> (IntMap.Key -> v -> EventWriterT t w m v')
172− -> IntMap v
173− -> Event t (p v)
174− -> EventWriterT t w m (IntMap v', Event t (p v'))
175−sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
164+sequenceIntMapWithAdjustEventWriterTWith
165+ :: forall t m p w v v'
166+ . ( Reflex t
167+ , MonadHold t m
168+ , Semigroup w
169+ , Functor p
170+ , Patch (p (Event t w))
171+ , PatchTarget (p (Event t w)) ~ IntMap (Event t w)
172+ , Patch (p w)
173+ , PatchTarget (p w) ~ IntMap w
174+ )
175+ => ( (IntMap.Key -> v -> m (Event t w, v'))
176+ -> IntMap v
177+ -> Event t (p v)
178+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
179+ )
180+ -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w)))
181+ -> (Event t (p (Event t w)) -> Event t (p w))
182+ -> (IntMap.Key -> v -> EventWriterT t w m v')
183+ -> IntMap v
184+ -> Event t (p v)
185+ -> EventWriterT t w m (IntMap v', Event t (p v'))
186+sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do
176187 let f' :: IntMap.Key -> v -> m (Event t w, v')
177188 f' k v = swap <$> runEventWriterT (f k v)
178189 (children0, children') <- base f' dm0 dm'
@@ -182,26 +193,39 @@ sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncreme
182193 requests0 = fmap fst children0
183194 requests' :: Event t (p (Event t w))
184195 requests' = fmapCheap (fmap fst) children'
185− childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
186− tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
196+ e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'
197+ tellEvent $ fforMaybeCheap e $ \m ->
198+ case IntMap.elems m of
199+ [] -> Nothing
200+ h : t -> Just $ sconcat $ h :| t
187201 return (result0, result')
188202
189203-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
190−sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
191− => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
192− -> DMap k v
193− -> Event t (p k v)
194− -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
195− )
196− -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
197− -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
198− -> (p' (Some k) (Event t w) -> [Event t w])
199− -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
200− -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
201− -> DMap k v
202− -> Event t (p k v)
203− -> EventWriterT t w m (DMap k v', Event t (p k v'))
204−sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
204+sequenceDMapWithAdjustEventWriterTWith
205+ :: forall t m p p' w k v v'
206+ . ( Reflex t
207+ , MonadHold t m
208+ , Semigroup w
209+ , Patch (p' (Some k) (Event t w))
210+ , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)
211+ , GCompare k
212+ , Patch (p' (Some k) w)
213+ , PatchTarget (p' (Some k) w) ~ Map (Some k) w
214+ )
215+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
216+ -> DMap k v
217+ -> Event t (p k v)
218+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
219+ )
220+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
221+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
222+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w)))
223+ -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w))
224+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
225+ -> DMap k v
226+ -> Event t (p k v)
227+ -> EventWriterT t w m (DMap k v', Event t (p k v'))
228+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do
205229 let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
206230 f' k v = Compose . swap <$> runEventWriterT (f k v)
207231 (children0, children') <- base f' dm0 dm'
@@ -211,26 +235,13 @@ sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewEle
211235 requests0 = weakenDMapWith (fst . getCompose) children0
212236 requests' :: Event t (p' (Some k) (Event t w))
213237 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
214− childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
215− tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
238+ e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'
239+ tellEvent $ fforMaybeCheap e $ \m ->
240+ case Map.elems m of
241+ [] -> Nothing
242+ h : t -> Just $ sconcat $ h :| t
216243 return (result0, result')
217244
218−tellEventsPromptly
219− :: ( Foldable f
220− , Reflex t
221− , MonadHold t m
222− , EventWriter t w m
223− )
224− => Event t a
225− -> (a -> [Event t w])
226− -> Event t (f w)
227− -> m ()
228−tellEventsPromptly requests' patchNewElements mergedChildRequestMap = do
229− let patch0 = fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of
230− [] -> Nothing
231− h : t -> Just $ sconcat $ h :| t
232− tellEvent =<< switchHoldPromptOnly patch0 (fmapCheap (mconcat . patchNewElements) requests')
233−
234245instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
235246 type Performable (EventWriterT t w m) = Performable m
236247 performEvent_ = lift . performEvent_
@@ -267,6 +278,9 @@ instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) wher
267278 askQueryResult = lift askQueryResult
268279 queryIncremental = lift . queryIncremental
269280
281+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (EventWriterT t v m) where
282+ tellDyn = lift . tellDyn
283+
270284instance PrimMonad m => PrimMonad (EventWriterT t w m) where
271285 type PrimState (EventWriterT t w m) = PrimState m
272286 primitive = lift . primitive
src/Reflex/FunctorMaybe.hs+10
@@ -4,6 +4,10 @@ module Reflex.FunctorMaybe
44 ( FunctorMaybe (..)
55 ) where
66
7+import Data.IntMap (IntMap)
8+import qualified Data.IntMap as IntMap
9+import Data.Map (Map)
10+import qualified Data.Map as Map
711import Data.Maybe
812
913--TODO: See if there's a better class in the standard libraries already
@@ -31,3 +35,9 @@ instance FunctorMaybe Maybe where
3135-- | @fmapMaybe = mapMaybe@
3236instance FunctorMaybe [] where
3337 fmapMaybe = mapMaybe
38+
39+instance FunctorMaybe (Map k) where
40+ fmapMaybe = Map.mapMaybe
41+
42+instance FunctorMaybe IntMap where
43+ fmapMaybe = IntMap.mapMaybe
src/Reflex/Optimizer.hs+5
@@ -16,6 +16,11 @@ import Control.Arrow
1616import CoreMonad
1717import Data.String
1818import GhcPlugins
19+
20+#if MIN_VERSION_base(4,9,0)
21+import Prelude hiding ((<>))
22+#endif
23+
1924#endif
2025
2126#ifdef ghcjs_HOST_OS
src/Reflex/Query/Base.hs−7
@@ -278,13 +278,6 @@ instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
278278instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
279279 (<>) = liftA2 (S.<>)
280280
281−
282−mapQuery :: QueryMorphism q q' -> q -> q'
283−mapQuery = _queryMorphism_mapQuery
284−
285−mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
286−mapQueryResult = _queryMorphism_mapQueryResult
287−
288281-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
289282withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
290283 => QueryMorphism q q'
src/Reflex/Query/Class.hs+23
@@ -15,12 +15,18 @@ module Reflex.Query.Class
1515 , MonadQuery (..)
1616 , tellQueryDyn
1717 , queryDyn
18+ , mapQuery
19+ , mapQueryResult
1820 ) where
1921
22+import Control.Category (Category)
23+import qualified Control.Category as Cat
2024import Control.Monad.Reader
2125import Data.Bits
2226import Data.Data
2327import Data.Ix
28+import Data.Map.Monoidal (MonoidalMap)
29+import qualified Data.Map.Monoidal as MonoidalMap
2430import Data.Semigroup
2531import Foreign.Storable
2632
@@ -30,6 +36,10 @@ class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
3036 type QueryResult a :: *
3137 crop :: a -> QueryResult a -> QueryResult a
3238
39+instance (Ord k, Query v) => Query (MonoidalMap k v) where
40+ type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
41+ crop q r = MonoidalMap.intersectionWith (flip crop) r q
42+
3343-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type
3444-- and compatible with the query relationship when acting on the query result
3545data QueryMorphism q q' = QueryMorphism
@@ -37,6 +47,19 @@ data QueryMorphism q q' = QueryMorphism
3747 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
3848 }
3949
50+instance Category QueryMorphism where
51+ id = QueryMorphism id id
52+ qm . qm' = QueryMorphism
53+ { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'
54+ , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm
55+ }
56+
57+mapQuery :: QueryMorphism q q' -> q -> q'
58+mapQuery = _queryMorphism_mapQuery
59+
60+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
61+mapQueryResult = _queryMorphism_mapQueryResult
62+
4063-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app
4164newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
4265 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
test/EventWriterT.hs+52−3
@@ -1,4 +1,5 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
23{-# LANGUAGE RecursiveDo #-}
34{-# LANGUAGE ScopedTypeVariables #-}
45module Main where
@@ -6,6 +7,9 @@ module Main where
67import Control.Lens
78import Control.Monad
89import Control.Monad.Fix
10+import qualified Data.Dependent.Map as DMap
11+import Data.Functor.Misc
12+import qualified Data.Map as M
913import Data.These
1014
1115import Reflex
@@ -28,6 +32,10 @@ main = do
2832 print os2
2933 os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
3034 print os3
35+ os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]
36+ print os4
37+ os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]
38+ print os5
3139 return ()
3240
3341unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
@@ -59,7 +67,48 @@ testMoribundTellEvent
5967 => Event t ()
6068 -> EventWriterT t [Int] m ()
6169testMoribundTellEvent pulse = do
62− rec let tellIntOnReplce :: Int -> EventWriterT t [Int] m ()
63− tellIntOnReplce x = tellEvent $ [x] <$ rwrFinished
64− (_, rwrFinished) <- runWithReplace (tellIntOnReplce 1) $ tellIntOnReplce 2 <$ pulse
70+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
71+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
72+ (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse
73+ return ()
74+
75+-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'.
76+testMoribundTellEventDMap
77+ :: forall t m
78+ . ( Reflex t
79+ , Adjustable t m
80+ , MonadHold t m
81+ , MonadFix m
82+ )
83+ => Event t ()
84+ -> EventWriterT t [Int] m ()
85+testMoribundTellEventDMap pulse = do
86+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
87+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
88+ (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
89+ traverseDMapWithKeyWithAdjust
90+ (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v)
91+ (mapToDMap $ M.singleton () 1)
92+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
93+ return ()
94+
95+-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's
96+-- during the same frame as other elements are updated.
97+testLiveTellEventDMap
98+ :: forall t m
99+ . ( Reflex t
100+ , Adjustable t m
101+ , MonadHold t m
102+ , MonadFix m
103+ )
104+ => Event t ()
105+ -> EventWriterT t [Int] m ()
106+testLiveTellEventDMap pulse = do
107+ rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
108+ tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
109+ (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
110+ traverseDMapWithKeyWithAdjust
111+ (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k)
112+ (mapToDMap $ M.singleton 1 ())
113+ ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
65114 return ()
test/Reflex/Test/CrossImpl.hs+1
@@ -30,6 +30,7 @@ import Data.Foldable
3030import Data.Map.Strict (Map)
3131import qualified Data.Map.Strict as Map
3232import qualified Data.Set as Set
33+import Data.Monoid
3334import Data.Traversable
3435import System.Exit
3536import System.Mem