git.iko.soy/patch
on c67a3fc help sign in
patch/src/Reflex/Dynamic.hs
524 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) Identity) <- distributeDMapOverDyn . DMap.fromList . map (\(k, v) -> Const2 k :=> v) $ zip [0 :: Int ..] es
231 mapDyn (mconcat . map (\(Const2 _ :=> Identity 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 k (Dynamic t) -> m (Dynamic t (DMap k Identity))
236distributeDMapOverDyn dm = case DMap.toList dm of
237 [] -> return $ constDyn DMap.empty
238 [k :=> v] -> mapDyn (DMap.singleton k . Identity) v
239 _ -> do
240 let edmPre = merge $ rewrapDMap updated dm
241 edm :: Event t (DMap k Identity) = 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 Identity) = pull $ do
248 liftM DMap.fromList . forM (DMap.toList dm) $ \(k :=> dv) -> liftM ((k :=>) . Identity) . sample $ current dv
249 bbdm :: Behavior t (Behavior t (DMap k Identity)) <- 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)
388 (fan $ attachWith (\k0 k1 -> if k0 == k1
389 then DMap.empty
390 else DMap.fromList [Const2 k0 :=> Identity False,
391 Const2 k1 :=> Identity True])
392 (current k) (updated k))
394--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
395-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)
396-- mapping over the original 'Dynamic' and checking whether it is equal to the given key.
397getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
398getDemuxed d k = do
399 let e = select (demuxSelector d) (Const2 k)
400 bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e
401 let b = pull $ join $ sample bb
402 return $ Dynamic b e
404--------------------------------------------------------------------------------
405-- collectDyn
406--------------------------------------------------------------------------------
408--TODO: This whole section is badly in need of cleanup
410data FHList f l where
411 FHNil :: FHList f '[]
412 FHCons :: f e -> FHList f l -> FHList f (e ': l)
414instance GEq (HListPtr l) where
415 HHeadPtr `geq` HHeadPtr = Just Refl
416 HHeadPtr `geq` HTailPtr _ = Nothing
417 HTailPtr _ `geq` HHeadPtr = Nothing
418 HTailPtr a `geq` HTailPtr b = a `geq` b
420instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
421 HHeadPtr `gcompare` HHeadPtr = GEQ
422 HHeadPtr `gcompare` HTailPtr _ = GLT
423 HTailPtr _ `gcompare` HHeadPtr = GGT
424 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
426data HListPtr l a where
427 HHeadPtr :: HListPtr (h ': t) h
428 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
430fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
431fhlistToDMap = DMap.fromList . go
432 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
433 go = \case
434 FHNil -> []
435 FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> (HTailPtr p) :=> v) (go t)
437class RebuildSortedHList l where
438 rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l
439 rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l
441instance RebuildSortedHList '[] where
442 rebuildSortedFHList l = case l of
443 [] -> FHNil
444 _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
445 rebuildSortedHList l = case l of
446 [] -> HNil
447 _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"
449instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
450 rebuildSortedFHList l = case l of
451 ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
452 _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
453 rebuildSortedHList l = case l of
454 ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
455 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
457dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
458dmapToHList = rebuildSortedHList . DMap.toList
460distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
461distributeFHListOverDyn l = mapDyn dmapToHList =<< distributeDMapOverDyn (fhlistToDMap l)
462{-
463distributeFHListOverDyn l = do
464 let ec = undefined
465 c0 = pull $ sequenceFHList $ natMap (sample . current) l
466 bbc <- hold c0 $ fmap constant ec
467 let bc = pull $ sample =<< sample bbc
468 return $ Dynamic bc ec
469-}
471class AllAreFunctors (f :: a -> *) (l :: [a]) where
472 type FunctorList f l :: [*]
473 toFHList :: HList (FunctorList f l) -> FHList f l
474 fromFHList :: FHList f l -> HList (FunctorList f l)
476instance AllAreFunctors f '[] where
477 type FunctorList f '[] = '[]
478 toFHList l = case l of
479 HNil -> FHNil
480 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
481 fromFHList FHNil = HNil
483instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
484 type FunctorList f (h ': t) = f h ': FunctorList f t
485 toFHList l = case l of
486 a `HCons` b -> a `FHCons` toFHList b
487 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
488 fromFHList (a `FHCons` b) = a `HCons` fromFHList b
490collectDyn :: ( RebuildSortedHList (HListElems b)
491 , IsHList a, IsHList b
492 , AllAreFunctors (Dynamic t) (HListElems b)
493 , Reflex t, MonadHold t m
494 , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
495 ) => a -> m (Dynamic t b)
496collectDyn ds =
497 mapDyn fromHList =<< distributeFHListOverDyn (toFHList $ toHList ds)
499-- Poor man's Generic
500class IsHList a where
501 type HListElems a :: [*]
502 toHList :: a -> HList (HListElems a)
503 fromHList :: HList (HListElems a) -> a
505instance IsHList (a, b) where
506 type HListElems (a, b) = [a, b]
507 toHList (a, b) = hBuild a b
508 fromHList l = case l of
509 a `HCons` b `HCons` HNil -> (a, b)
510 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
512instance IsHList (a, b, c, d) where
513 type HListElems (a, b, c, d) = [a, b, c, d]
514 toHList (a, b, c, d) = hBuild a b c d
515 fromHList l = case l of
516 a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
517 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
519instance IsHList (a, b, c, d, e, f) where
520 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
521 toHList (a, b, c, d, e, f) = hBuild a b c d e f
522 fromHList l = case l of
523 a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
524 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139