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