git.iko.soy/patch
on 832580f help sign in
patch/src/Reflex/Dynamic.hs
407 lines 17 kB history raw
1{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, DataKinds, PolyKinds #-}
2module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update
3 , current
4 , updated
5 , constDyn
6 , holdDyn
7 , nubDyn
8 , count
9 , toggle
10 , switchPromptlyDyn
11 , tagDyn
12 , attachDyn
13 , attachDynWith
14 , attachDynWithMaybe
15 , mapDyn
16 , forDyn
17 , mapDynM
18 , foldDyn
19 , foldDynM
20 , combineDyn
21 , collectDyn
22 , mconcatDyn
23 , distributeDMapOverDyn
24 , joinDyn
25 , joinDynThroughMap
26 , traceDyn
27 , traceDynWith
28 , splitDyn
29 , Demux
30 , demux
31 , getDemuxed
32 -- Things that probably aren't very useful:
33 , HList (..)
34 , FHList (..)
35 , distributeFHListOverDyn
36 -- Unsafe
37 , unsafeDynamic
38 ) where
40import Prelude hiding (mapM, mapM_)
42import Reflex.Class
43import Data.Functor.Misc
45import Control.Monad hiding (mapM, mapM_, forM, forM_)
46import Control.Monad.Fix
47import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_)
48import Data.These
49import Data.Traversable (mapM, forM)
50import Data.Align
51import Data.Map (Map)
52import qualified Data.Map as Map
53import Data.Dependent.Map (DMap)
54import qualified Data.Dependent.Map as DMap
55import Data.Dependent.Sum (DSum (..))
56import Data.GADT.Compare (GCompare (..), GEq (..), (:~:) (..), GOrdering (..))
57import Data.Monoid
58--import Data.HList (HList (..), hBuild)
60data HList (l::[*]) where
61 HNil :: HList '[]
62 HCons :: e -> HList l -> HList (e ': l)
64infixr 2 `HCons`
66type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]
67type instance HRevApp '[] l = l
68type instance HRevApp (e ': l) l' = HRevApp l (e ': l')
70hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)
71hRevApp HNil l = l
72hRevApp (HCons x l) l' = hRevApp l (HCons x l')
74hReverse :: HList l -> HList (HRevApp l '[])
75hReverse l = hRevApp l HNil
77hBuild :: (HBuild' '[] r) => r
78hBuild = hBuild' HNil
80class HBuild' l r where
81 hBuild' :: HList l -> r
83instance (l' ~ HRevApp l '[])
84 => HBuild' l (HList l') where
85 hBuild' l = hReverse l
87instance HBuild' (a ': l) r
88 => HBuild' l (a->r) where
89 hBuild' l x = hBuild' (HCons x l)
92data Dynamic t a
93 = Dynamic (Behavior t a) (Event t a)
95unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a
96unsafeDynamic = Dynamic
98current :: Dynamic t a -> Behavior t a
99current (Dynamic b _) = b
101updated :: Dynamic t a -> Event t a
102updated (Dynamic _ e) = e
104constDyn :: Reflex t => a -> Dynamic t a
105constDyn x = Dynamic (constant x) never
107holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)
108holdDyn v0 e = do
109 b <- hold v0 e
110 return $ Dynamic b e
112nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
113nubDyn d =
114 let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)
115 in Dynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior
117{-
118instance Reflex t => Functor (Dynamic t) where
119 fmap f d =
120 let e' = fmap f $ updated d
121 eb' = push (\b' -> liftM Just $ constant b') e'
122 b0 = fmap f $ current d
124-}
126mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
127mapDyn f = mapDynM $ return . f
129forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
130forDyn = flip mapDyn
132{-# INLINE mapDynM #-}
133mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)
134mapDynM f d = do
135 let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) $ updated d
136 eb' = fmap constant e'
137 v0 = pull $ f =<< sample (current d)
138 bb' :: Behavior t (Behavior t b) <- hold v0 eb'
139 let b' = pull $ sample =<< sample bb'
140 return $ Dynamic b' e'
142foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
143foldDyn f = foldDynM (\o v -> return $ f o v)
145foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
146foldDynM f z e = do
147 rec let e' = flip push e $ \o -> do
148 v <- sample b'
149 liftM Just $ f o v
150 b' <- hold z e'
151 return $ Dynamic b' e'
153count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
154count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
156toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
157toggle = foldDyn (const not)
159-- | Switches to the new event whenever it receives one. Switching occurs *before* occurring the inner event.
160switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
161switchPromptlyDyn de =
162 let eLag = switch $ current de
163 eCoincidences = coincidence $ updated de
164 in leftmost [eCoincidences, eLag]
166{-
168mergeEventsWith :: Reflex t m => (a -> a -> a) -> Event t a -> Event t a -> m (Event t a)
169mergeEventsWith f ea eb = mapE (mergeThese f) =<< alignEvents ea eb
171firstE :: (Reflex t m) => [Event t a] -> m (Event t a)
172firstE [] = return never
173firstE (h:t) = mergeEventsLeftBiased h =<< firstE t
175concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)
176concatEventsWith _ [] = return never
177concatEventsWith _ [e] = return e
178concatEventsWith f es = mapEM (liftM (foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) . sequenceDmap) <=< mergeEventDMap $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
179--concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t
181mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)
182mconcatE = concatEventsWith mappend
183-}
185splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
186splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)
188mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
189mconcatDyn es = do
190 ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
191 mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm
193distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))
194distributeDMapOverDyn dm = case DMap.toList dm of
195 [] -> return $ constDyn DMap.empty
196 [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v
197 _ -> do
198 let edmPre = merge $ rewrapDMap updated dm
199 edm :: Event t (DMap k) = flip push edmPre $ \o -> return . Just =<< do
200 let f _ = \case
201 This origDyn -> sample $ current origDyn
202 That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"
203 These _ (Identity newVal) -> return newVal
204 sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)
205 dm0 :: Behavior t (DMap k) = pull $ do
206 liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv
207 bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm
208 let bdm = pull $ sample =<< sample bbdm
209 return $ Dynamic bdm edm
211combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
212combineDyn f da db = do
213 let eab = align (updated da) (updated db)
214 ec = flip push eab $ \o -> do
215 (a, b) <- case o of
216 This a -> do
217 b <- sample $ current db
218 return (a, b)
219 That b -> do
220 a <- sample $ current da
221 return (a, b)
222 These a b -> return (a, b)
223 return $ Just $ f a b
224 c0 :: Behavior t c = pull $ liftM2 f (sample $ current da) (sample $ current db)
225 bbc :: Behavior t (Behavior t c) <- hold c0 $ fmap constant ec
226 let bc :: Behavior t c = pull $ sample =<< sample bbc
227 return $ Dynamic bc ec
229{-
230tagInnerDyn :: Reflex t => Event t (Dynamic t a) -> Event t a
231tagInnerDyn e =
232 let eSlow = push (liftM Just . sample . current) e
233 eFast = coincidence $ fmap updated e
234 in leftmost [eFast, eSlow]
235-}
237joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a
238joinDyn dd =
239 let b' = pull $ sample . current =<< sample (current dd)
240 eOuter :: Event t a = pushAlways (sample . current) $ updated dd
241 eInner :: Event t a = switch $ fmap updated (current dd)
242 eBoth :: Event t a = coincidence $ fmap updated (updated dd)
243 e' = leftmost [eBoth, eOuter, eInner]
244 in Dynamic b' e'
246--TODO: Generalize this to functors other than Maps
247joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
248joinDynThroughMap dd =
249 let b' = pull $ mapM (sample . current) =<< sample (current dd)
250 eOuter :: Event t (Map k a) = pushAlways (mapM (sample . current)) $ updated dd
251 eInner :: Event t (Map k a) = attachWith (flip Map.union) b' $ switch $ fmap (mergeMap . fmap updated) (current dd) --Note: the flip is important because Map.union is left-biased
252 readNonFiring :: MonadSample t m => These (Dynamic t a) a -> m a
253 readNonFiring = \case
254 This d -> sample $ current d
255 That a -> return a
256 These _ a -> return a
257 eBoth :: Event t (Map k a) = coincidence $ fmap (\m -> pushAlways (mapM readNonFiring . align m) $ mergeMap $ fmap updated m) (updated dd)
258 e' = leftmost [eBoth, eOuter, eInner]
259 in Dynamic b' e'
261traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
262traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
264traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
265traceDynWith f d =
266 let e' = traceEventWith f $ updated d
267 in Dynamic (current d) e'
269tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
270tagDyn = attachDynWith const
272attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
273attachDyn = attachDynWith (,)
275attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
276attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b
278attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
279attachDynWithMaybe f d e =
280 let e' = attach (current d) e
281 in fforMaybe (align e' $ updated d) $ \case
282 This (a, b) -> f a b -- Only the tagging event is firing, so use that
283 These (_, b) a -> f a b -- Both events are firing, so use the newer value
284 That _ -> Nothing -- The tagging event isn't firing, so don't fire
286--------------------------------------------------------------------------------
287-- Demux
288--------------------------------------------------------------------------------
290data Demux t k = Demux { demuxValue :: Behavior t k
291 , demuxSelector :: EventSelector t (Const2 k Bool)
292 }
294demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
295demux k = Demux (current k) (fan $ attachWith (\k0 k1 -> if k0 == k1 then DMap.empty else DMap.fromList [Const2 k0 :=> False, Const2 k1 :=> True]) (current k) (updated k))
297--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out
298getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
299getDemuxed d k = do
300 let e = select (demuxSelector d) (Const2 k)
301 bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e
302 let b = pull $ join $ sample bb
303 return $ Dynamic b e
305--------------------------------------------------------------------------------
306-- collectDyn
307--------------------------------------------------------------------------------
309--TODO: This whole section is badly in need of cleanup
311data FHList f l where
312 FHNil :: FHList f '[]
313 FHCons :: f e -> FHList f l -> FHList f (e ': l)
315instance GEq (HListPtr l) where
316 HHeadPtr `geq` HHeadPtr = Just Refl
317 HHeadPtr `geq` HTailPtr _ = Nothing
318 HTailPtr _ `geq` HHeadPtr = Nothing
319 HTailPtr a `geq` HTailPtr b = a `geq` b
321instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
322 HHeadPtr `gcompare` HHeadPtr = GEQ
323 HHeadPtr `gcompare` HTailPtr _ = GLT
324 HTailPtr _ `gcompare` HHeadPtr = GGT
325 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
327data HListPtr l a where
328 HHeadPtr :: HListPtr (h ': t) h
329 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
331fhlistToDMap :: forall f l. FHList f l -> DMap (WrapArg f (HListPtr l))
332fhlistToDMap = DMap.fromList . go
333 where go :: forall l'. FHList f l' -> [DSum (WrapArg f (HListPtr l'))]
334 go = \case
335 FHNil -> []
336 FHCons h t -> (WrapArg HHeadPtr :=> h) : map (\(WrapArg p :=> v) -> WrapArg (HTailPtr p) :=> v) (go t)
338class RebuildSortedHList l where
339 rebuildSortedFHList :: [DSum (WrapArg f (HListPtr l))] -> FHList f l
340 rebuildSortedHList :: [DSum (HListPtr l)] -> HList l
342instance RebuildSortedHList '[] where
343 rebuildSortedFHList [] = FHNil
344 rebuildSortedHList [] = HNil
346instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
347 rebuildSortedFHList ((WrapArg HHeadPtr :=> h) : t) = FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t
348 rebuildSortedHList ((HHeadPtr :=> h) : t) = HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t
350dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l
351dmapToHList = rebuildSortedHList . DMap.toList
353distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
354distributeFHListOverDyn l = mapDyn dmapToHList =<< distributeDMapOverDyn (fhlistToDMap l)
355{-
356distributeFHListOverDyn l = do
357 let ec = undefined
358 c0 = pull $ sequenceFHList $ natMap (sample . current) l
359 bbc <- hold c0 $ fmap constant ec
360 let bc = pull $ sample =<< sample bbc
361 return $ Dynamic bc ec
362-}
364class AllAreFunctors (f :: a -> *) (l :: [a]) where
365 type FunctorList f l :: [*]
366 toFHList :: HList (FunctorList f l) -> FHList f l
367 fromFHList :: FHList f l -> HList (FunctorList f l)
369instance AllAreFunctors f '[] where
370 type FunctorList f '[] = '[]
371 toFHList HNil = FHNil
372 fromFHList FHNil = HNil
374instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
375 type FunctorList f (h ': t) = f h ': FunctorList f t
376 toFHList (a `HCons` b) = a `FHCons` toFHList b
377 fromFHList (a `FHCons` b) = a `HCons` fromFHList b
379collectDyn :: ( RebuildSortedHList (HListElems b)
380 , IsHList a, IsHList b
381 , AllAreFunctors (Dynamic t) (HListElems b)
382 , Reflex t, MonadHold t m
383 , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
384 ) => a -> m (Dynamic t b)
385collectDyn ds =
386 mapDyn fromHList =<< distributeFHListOverDyn (toFHList $ toHList ds)
388-- Poor man's Generic
389class IsHList a where
390 type HListElems a :: [*]
391 toHList :: a -> HList (HListElems a)
392 fromHList :: HList (HListElems a) -> a
394instance IsHList (a, b) where
395 type HListElems (a, b) = [a, b]
396 toHList (a, b) = hBuild a b
397 fromHList (a `HCons` b `HCons` HNil) = (a, b)
399instance IsHList (a, b, c, d) where
400 type HListElems (a, b, c, d) = [a, b, c, d]
401 toHList (a, b, c, d) = hBuild a b c d
402 fromHList (a `HCons` b `HCons` c `HCons` d `HCons` HNil) = (a, b, c, d)
404instance IsHList (a, b, c, d, e, f) where
405 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
406 toHList (a, b, c, d, e, f) = hBuild a b c d e f
407 fromHList (a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil) = (a, b, c, d, e, f)