git.iko.soy/patch
on aef5e79 help sign in
patch/src/Reflex/Dynamic.hs
519 lines 23 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 , foldDynMaybe
21 , foldDynMaybeM
22 , combineDyn
23 , collectDyn
24 , mconcatDyn
25 , distributeDMapOverDyn
26 , joinDyn
27 , joinDynThroughMap
28 , traceDyn
29 , traceDynWith
30 , splitDyn
31 , Demux
32 , demux
33 , getDemuxed
34 -- Things that probably aren't very useful:
35 , HList (..)
36 , FHList (..)
37 , distributeFHListOverDyn
38 -- Unsafe
39 , unsafeDynamic
40 ) where
42import Prelude hiding (mapM, mapM_)
44import Reflex.Class
45import Data.Functor.Misc
47import Control.Monad hiding (mapM, mapM_, forM, forM_)
48import Control.Monad.Fix
49import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_)
50import Data.These
51import Data.Traversable (mapM, forM)
52import Data.Align
53import Data.Map (Map)
54import qualified Data.Map as Map
55import Data.Dependent.Map (DMap)
56import qualified Data.Dependent.Map as DMap
57import Data.Dependent.Sum (DSum (..))
58import Data.GADT.Compare (GCompare (..), GEq (..), (:~:) (..), GOrdering (..))
59import Data.Monoid
60--import Data.HList (HList (..), hBuild)
62data HList (l::[*]) where
63 HNil :: HList '[]
64 HCons :: e -> HList l -> HList (e ': l)
66infixr 2 `HCons`
68type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]
69type instance HRevApp '[] l = l
70type instance HRevApp (e ': l) l' = HRevApp l (e ': l')
72hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)
73hRevApp HNil l = l
74hRevApp (HCons x l) l' = hRevApp l (HCons x l')
76hReverse :: HList l -> HList (HRevApp l '[])
77hReverse l = hRevApp l HNil
79hBuild :: (HBuild' '[] r) => r
80hBuild = hBuild' HNil
82class HBuild' l r where
83 hBuild' :: HList l -> r
85instance (l' ~ HRevApp l '[])
86 => HBuild' l (HList l') where
87 hBuild' l = hReverse l
89instance HBuild' (a ': l) r
90 => HBuild' l (a->r) where
91 hBuild' l x = hBuild' (HCons x l)
93-- | A container for a value that can change over time and allows notifications on changes.
94-- Basically a combination of a 'Behavior' and an 'Event', with a rule that the Behavior will
95-- change if and only if the Event fires.
96--
97-- Although @Dynamic@ logically has a 'Functor' instance, currently it can\'t
98-- be implemented without potentially requiring the mapped function to be
99-- evaluated twice. Instead, you can use 'mapDyn', which runs in a 'MonadHold'
100-- instance, to achieve the same result.
101data Dynamic t a
102 = Dynamic (Behavior t a) (Event t a)
104unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a
105unsafeDynamic = Dynamic
107-- | Extract the 'Behavior' of a 'Dynamic'.
108current :: Dynamic t a -> Behavior t a
109current (Dynamic b _) = b
111-- | Extract the 'Event' of the 'Dynamic'.
112updated :: Dynamic t a -> Event t a
113updated (Dynamic _ e) = e
115-- | 'Dynamic' with the constant supplied value.
116constDyn :: Reflex t => a -> Dynamic t a
117constDyn x = Dynamic (constant x) never
119-- | Create a 'Dynamic' using the initial value that changes every
120-- time the 'Event' occurs.
121holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)
122holdDyn v0 e = do
123 b <- hold v0 e
124 return $ Dynamic b e
126-- | Create a new 'Dynamic' that only signals changes if the values
127-- actually changed.
128nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
129nubDyn d =
130 let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)
131 in Dynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior
133{-
134instance Reflex t => Functor (Dynamic t) where
135 fmap f d =
136 let e' = fmap f $ updated d
137 eb' = push (\b' -> liftM Just $ constant b') e'
138 b0 = fmap f $ current d
140-}
142-- | Map a function over a 'Dynamic'.
143mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
144mapDyn f = mapDynM $ return . f
146-- | Flipped version of 'mapDyn'.
147forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
148forDyn = flip mapDyn
150-- | Map a monadic function over a 'Dynamic'. The only monadic action that the given function can
151-- perform is 'sample'.
152{-# INLINE mapDynM #-}
153mapDynM :: 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)
154mapDynM f d = do
155 let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) $ updated d
156 eb' = fmap constant e'
157 v0 = pull $ f =<< sample (current d)
158 bb' :: Behavior t (Behavior t b) <- hold v0 eb'
159 let b' = pull $ sample =<< sample bb'
160 return $ Dynamic b' e'
162-- | Create a 'Dynamic' using the initial value and change it each
163-- time the 'Event' occurs using a folding function on the previous
164-- value and the value of the 'Event'.
165foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
166foldDyn f = foldDynMaybe $ \o v -> Just $ f o v
168-- | Create a 'Dynamic' using the initial value and change it each
169-- time the 'Event' occurs using a monadic folding function on the
170-- previous value and the value of the 'Event'.
171foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
172foldDynM f = foldDynMaybeM $ \o v -> liftM Just $ f o v
174foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
175foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v
177foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
178foldDynMaybeM f z e = do
179 rec let e' = flip push e $ \o -> do
180 v <- sample b'
181 f o v
182 b' <- hold z e'
183 return $ Dynamic b' e'
185-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
186count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
187count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
189-- | Create a new 'Dynamic' using the initial value that flips its
190-- value every time the 'Event' occurs.
191toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
192toggle = foldDyn (const not)
194-- | Switches to the new 'Event' whenever it receives one. Switching
195-- occurs *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the old and new
196-- inner Events fire simultaneously, the output will fire with the value of the *new* 'Event'.
197switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
198switchPromptlyDyn de =
199 let eLag = switch $ current de
200 eCoincidences = coincidence $ updated de
201 in leftmost [eCoincidences, eLag]
203{-
205mergeEventsWith :: Reflex t m => (a -> a -> a) -> Event t a -> Event t a -> m (Event t a)
206mergeEventsWith f ea eb = mapE (mergeThese f) =<< alignEvents ea eb
208firstE :: (Reflex t m) => [Event t a] -> m (Event t a)
209firstE [] = return never
210firstE (h:t) = mergeEventsLeftBiased h =<< firstE t
212concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)
213concatEventsWith _ [] = return never
214concatEventsWith _ [e] = return e
215concatEventsWith 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
216--concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t
218mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)
219mconcatE = concatEventsWith mappend
220-}
222-- | Split the 'Dynamic' into two 'Dynamic's, each taking the
223-- respective value of the tuple.
224splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
225splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)
227-- | Merge the 'Dynamic' values using their 'Monoid' instance.
228mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
229mconcatDyn es = do
230 ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
231 mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm
233-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of
234-- Dynamic values.
235distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))
236distributeDMapOverDyn dm = case DMap.toList dm of
237 [] -> return $ constDyn DMap.empty
238 [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v
239 _ -> do
240 let edmPre = merge $ rewrapDMap updated dm
241 edm :: Event t (DMap k) = flip push edmPre $ \o -> return . Just =<< do
242 let f _ = \case
243 This origDyn -> sample $ current origDyn
244 That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"
245 These _ (Identity newVal) -> return newVal
246 sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)
247 dm0 :: Behavior t (DMap k) = pull $ do
248 liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv
249 bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm
250 let bdm = pull $ sample =<< sample bbdm
251 return $ Dynamic bdm edm
253-- | Merge two 'Dynamic's into a new one using the provided
254-- function. The new 'Dynamic' changes its value each time one of the
255-- original 'Dynamic's changes its value.
256combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
257combineDyn f da db = do
258 let eab = align (updated da) (updated db)
259 ec = flip push eab $ \o -> do
260 (a, b) <- case o of
261 This a -> do
262 b <- sample $ current db
263 return (a, b)
264 That b -> do
265 a <- sample $ current da
266 return (a, b)
267 These a b -> return (a, b)
268 return $ Just $ f a b
269 c0 :: Behavior t c = pull $ liftM2 f (sample $ current da) (sample $ current db)
270 bbc :: Behavior t (Behavior t c) <- hold c0 $ fmap constant ec
271 let bc :: Behavior t c = pull $ sample =<< sample bbc
272 return $ Dynamic bc ec
274{-
275tagInnerDyn :: Reflex t => Event t (Dynamic t a) -> Event t a
276tagInnerDyn e =
277 let eSlow = push (liftM Just . sample . current) e
278 eFast = coincidence $ fmap updated e
279 in leftmost [eFast, eSlow]
280-}
282-- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value
283-- of the inner 'Dynamic'.
284joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a
285joinDyn dd =
286 let b' = pull $ sample . current =<< sample (current dd)
287 eOuter :: Event t a = pushAlways (sample . current) $ updated dd
288 eInner :: Event t a = switch $ fmap updated (current dd)
289 eBoth :: Event t a = coincidence $ fmap updated (updated dd)
290 e' = leftmost [eBoth, eOuter, eInner]
291 in Dynamic b' e'
293--TODO: Generalize this to functors other than Maps
294-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
295-- with the current values of the 'Dynamic's in a map.
296joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
297joinDynThroughMap dd =
298 let b' = pull $ mapM (sample . current) =<< sample (current dd)
299 eOuter :: Event t (Map k a) = pushAlways (mapM (sample . current)) $ updated dd
300 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
301 readNonFiring :: MonadSample t m => These (Dynamic t a) a -> m a
302 readNonFiring = \case
303 This d -> sample $ current d
304 That a -> return a
305 These _ a -> return a
306 eBoth :: Event t (Map k a) = coincidence $ fmap (\m -> pushAlways (mapM readNonFiring . align m) $ mergeMap $ fmap updated m) (updated dd)
307 e' = leftmost [eBoth, eOuter, eInner]
308 in Dynamic b' e'
310-- | Print the value of the 'Dynamic' on each change and prefix it
311-- with the provided string. This should /only/ be used for debugging.
312--
313-- Note: Just like Debug.Trace.trace, the value will only be shown if something
314-- else in the system is depending on it.
315traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
316traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
318-- | Print the result of applying the provided function to the value
319-- of the 'Dynamic' on each change. This should /only/ be used for
320-- debugging.
321--
322-- Note: Just like Debug.Trace.trace, the value will only be shown if something
323-- else in the system is depending on it.
324traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
325traceDynWith f d =
326 let e' = traceEventWith f $ updated d
327 in Dynamic (current d) e'
329-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
330-- each time the 'Event' occurs.
331--
332-- Note: `tagDyn d e` differs from `tag (current d) e` in the case that `e` is firing
333-- at the same time that `d` is changing. With `tagDyn d e`, the *new* value of `d`
334-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value
335-- will be used, since the 'Behavior' won't be updated until the end of the frame.
336-- Additionally, this means that the output 'Event' may not be used to directly change
337-- the input 'Dynamic', because that would mean its value depends on itself. When creating
338-- cyclic data flows, generally `tag (current d) e` is preferred.
339tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
340tagDyn = attachDynWith const
342-- | Attach the current value of the 'Dynamic' to the value of the
343-- 'Event' each time it occurs.
344--
345-- Note: `attachDyn d` is not the same as `attach (current d)`. See 'tagDyn' for details.
346attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
347attachDyn = attachDynWith (,)
349-- | Combine the current value of the 'Dynamic' with the value of the
350-- 'Event' each time it occurs.
351--
352-- Note: `attachDynWith f d` is not the same as `attachWith f (current d)`. See 'tagDyn' for details.
353attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
354attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b
356-- | Create a new 'Event' by combining the value at each occurence
357-- with the current value of the 'Dynamic' value and possibly
358-- filtering if the combining function returns 'Nothing'.
359--
360-- Note: `attachDynWithMaybe f d` is not the same as `attachWithMaybe f (current d)`. See 'tagDyn' for details.
361attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
362attachDynWithMaybe f d e =
363 let e' = attach (current d) e
364 in fforMaybe (align e' $ updated d) $ \case
365 This (a, b) -> f a b -- Only the tagging event is firing, so use that
366 These (_, b) a -> f a b -- Both events are firing, so use the newer value
367 That _ -> Nothing -- The tagging event isn't firing, so don't fire
369--------------------------------------------------------------------------------
370-- Demux
371--------------------------------------------------------------------------------
373-- | Represents a time changing value together with an 'EventSelector'
374-- that can efficiently detect when the underlying Dynamic has a particular value.
375-- This is useful for representing data like the current selection of a long list.
376--
377-- Semantically,
378-- > getDemuxed (demux d) k === mapDyn (== k) d
379-- However, the when getDemuxed is used multiple times, the complexity is only /O(log(n))/,
380-- rather than /O(n)/ for mapDyn.
381data Demux t k = Demux { demuxValue :: Behavior t k
382 , demuxSelector :: EventSelector t (Const2 k Bool)
383 }
385-- | Demultiplex an input value to a 'Demux' with many outputs. At any given time, whichever output is indicated by the given 'Dynamic' will be 'True'.
386demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
387demux 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))
389--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
390-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)
391-- mapping over the original 'Dynamic' and checking whether it is equal to the given key.
392getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
393getDemuxed d k = do
394 let e = select (demuxSelector d) (Const2 k)
395 bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e
396 let b = pull $ join $ sample bb
397 return $ Dynamic b e
399--------------------------------------------------------------------------------
400-- collectDyn
401--------------------------------------------------------------------------------
403--TODO: This whole section is badly in need of cleanup
405data FHList f l where
406 FHNil :: FHList f '[]
407 FHCons :: f e -> FHList f l -> FHList f (e ': l)
409instance GEq (HListPtr l) where
410 HHeadPtr `geq` HHeadPtr = Just Refl
411 HHeadPtr `geq` HTailPtr _ = Nothing
412 HTailPtr _ `geq` HHeadPtr = Nothing
413 HTailPtr a `geq` HTailPtr b = a `geq` b
415instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
416 HHeadPtr `gcompare` HHeadPtr = GEQ
417 HHeadPtr `gcompare` HTailPtr _ = GLT
418 HTailPtr _ `gcompare` HHeadPtr = GGT
419 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
421data HListPtr l a where
422 HHeadPtr :: HListPtr (h ': t) h
423 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
425fhlistToDMap :: forall f l. FHList f l -> DMap (WrapArg f (HListPtr l))
426fhlistToDMap = DMap.fromList . go
427 where go :: forall l'. FHList f l' -> [DSum (WrapArg f (HListPtr l'))]
428 go = \case
429 FHNil -> []
430 FHCons h t -> (WrapArg HHeadPtr :=> h) : map (\(WrapArg p :=> v) -> WrapArg (HTailPtr p) :=> v) (go t)
432class RebuildSortedHList l where
433 rebuildSortedFHList :: [DSum (WrapArg f (HListPtr l))] -> FHList f l
434 rebuildSortedHList :: [DSum (HListPtr l)] -> HList l
436instance RebuildSortedHList '[] where
437 rebuildSortedFHList l = case l of
438 [] -> FHNil
439 _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
440 rebuildSortedHList l = case l of
441 [] -> HNil
442 _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"
444instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
445 rebuildSortedFHList l = case l of
446 ((WrapArg HHeadPtr :=> h) : t) -> FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t
447 _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
448 rebuildSortedHList l = case l of
449 ((HHeadPtr :=> h) : t) -> HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t
450 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
452dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l
453dmapToHList = rebuildSortedHList . DMap.toList
455distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
456distributeFHListOverDyn l = mapDyn dmapToHList =<< distributeDMapOverDyn (fhlistToDMap l)
457{-
458distributeFHListOverDyn l = do
459 let ec = undefined
460 c0 = pull $ sequenceFHList $ natMap (sample . current) l
461 bbc <- hold c0 $ fmap constant ec
462 let bc = pull $ sample =<< sample bbc
463 return $ Dynamic bc ec
464-}
466class AllAreFunctors (f :: a -> *) (l :: [a]) where
467 type FunctorList f l :: [*]
468 toFHList :: HList (FunctorList f l) -> FHList f l
469 fromFHList :: FHList f l -> HList (FunctorList f l)
471instance AllAreFunctors f '[] where
472 type FunctorList f '[] = '[]
473 toFHList l = case l of
474 HNil -> FHNil
475 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
476 fromFHList FHNil = HNil
478instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
479 type FunctorList f (h ': t) = f h ': FunctorList f t
480 toFHList l = case l of
481 a `HCons` b -> a `FHCons` toFHList b
482 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
483 fromFHList (a `FHCons` b) = a `HCons` fromFHList b
485collectDyn :: ( RebuildSortedHList (HListElems b)
486 , IsHList a, IsHList b
487 , AllAreFunctors (Dynamic t) (HListElems b)
488 , Reflex t, MonadHold t m
489 , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
490 ) => a -> m (Dynamic t b)
491collectDyn ds =
492 mapDyn fromHList =<< distributeFHListOverDyn (toFHList $ toHList ds)
494-- Poor man's Generic
495class IsHList a where
496 type HListElems a :: [*]
497 toHList :: a -> HList (HListElems a)
498 fromHList :: HList (HListElems a) -> a
500instance IsHList (a, b) where
501 type HListElems (a, b) = [a, b]
502 toHList (a, b) = hBuild a b
503 fromHList l = case l of
504 a `HCons` b `HCons` HNil -> (a, b)
505 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
507instance IsHList (a, b, c, d) where
508 type HListElems (a, b, c, d) = [a, b, c, d]
509 toHList (a, b, c, d) = hBuild a b c d
510 fromHList l = case l of
511 a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
512 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
514instance IsHList (a, b, c, d, e, f) where
515 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
516 toHList (a, b, c, d, e, f) = hBuild a b c d e f
517 fromHList l = case l of
518 a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
519 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139