git.iko.soy/patch
on f565bee help sign in
patch/src/Reflex/Dynamic.hs
514 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.
96data Dynamic t a
97 = Dynamic (Behavior t a) (Event t a)
99unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a
100unsafeDynamic = Dynamic
102-- | Extract the 'Behavior' of a 'Dynamic'.
103current :: Dynamic t a -> Behavior t a
104current (Dynamic b _) = b
106-- | Extract the 'Event' of the 'Dynamic'.
107updated :: Dynamic t a -> Event t a
108updated (Dynamic _ e) = e
110-- | 'Dynamic' with the constant supplied value.
111constDyn :: Reflex t => a -> Dynamic t a
112constDyn x = Dynamic (constant x) never
114-- | Create a 'Dynamic' using the initial value that changes every
115-- time the 'Event' occurs.
116holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)
117holdDyn v0 e = do
118 b <- hold v0 e
119 return $ Dynamic b e
121-- | Create a new 'Dynamic' that only signals changes if the values
122-- actually changed.
123nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
124nubDyn d =
125 let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)
126 in Dynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior
128{-
129instance Reflex t => Functor (Dynamic t) where
130 fmap f d =
131 let e' = fmap f $ updated d
132 eb' = push (\b' -> liftM Just $ constant b') e'
133 b0 = fmap f $ current d
135-}
137-- | Map a function over a 'Dynamic'.
138mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
139mapDyn f = mapDynM $ return . f
141-- | Flipped version of 'mapDyn'.
142forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
143forDyn = flip mapDyn
145-- | Map a monadic function over a 'Dynamic'. The only monadic action that the given function can
146-- perform is 'sample'.
147{-# INLINE mapDynM #-}
148mapDynM :: 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)
149mapDynM f d = do
150 let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) $ updated d
151 eb' = fmap constant e'
152 v0 = pull $ f =<< sample (current d)
153 bb' :: Behavior t (Behavior t b) <- hold v0 eb'
154 let b' = pull $ sample =<< sample bb'
155 return $ Dynamic b' e'
157-- | Create a 'Dynamic' using the initial value and change it each
158-- time the 'Event' occurs using a folding function on the previous
159-- value and the value of the 'Event'.
160foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
161foldDyn f = foldDynMaybe $ \o v -> Just $ f o v
163-- | Create a 'Dynamic' using the initial value and change it each
164-- time the 'Event' occurs using a monadic folding function on the
165-- previous value and the value of the 'Event'.
166foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
167foldDynM f = foldDynMaybeM $ \o v -> liftM Just $ f o v
169foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
170foldDynMaybe f = foldDynMaybeM $ \o v -> return $ f o v
172foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
173foldDynMaybeM f z e = do
174 rec let e' = flip push e $ \o -> do
175 v <- sample b'
176 f o v
177 b' <- hold z e'
178 return $ Dynamic b' e'
180-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
181count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
182count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
184-- | Create a new 'Dynamic' using the initial value that flips its
185-- value every time the 'Event' occurs.
186toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
187toggle = foldDyn (const not)
189-- | Switches to the new 'Event' whenever it receives one. Switching
190-- occurs *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the old and new
191-- inner Events fire simultaneously, the output will fire with the value of the *new* 'Event'.
192switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
193switchPromptlyDyn de =
194 let eLag = switch $ current de
195 eCoincidences = coincidence $ updated de
196 in leftmost [eCoincidences, eLag]
198{-
200mergeEventsWith :: Reflex t m => (a -> a -> a) -> Event t a -> Event t a -> m (Event t a)
201mergeEventsWith f ea eb = mapE (mergeThese f) =<< alignEvents ea eb
203firstE :: (Reflex t m) => [Event t a] -> m (Event t a)
204firstE [] = return never
205firstE (h:t) = mergeEventsLeftBiased h =<< firstE t
207concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)
208concatEventsWith _ [] = return never
209concatEventsWith _ [e] = return e
210concatEventsWith 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
211--concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t
213mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)
214mconcatE = concatEventsWith mappend
215-}
217-- | Split the 'Dynamic' into two 'Dynamic's, each taking the
218-- respective value of the tuple.
219splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
220splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)
222-- | Merge the 'Dynamic' values using their 'Monoid' instance.
223mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
224mconcatDyn es = do
225 ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
226 mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm
228-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of
229-- Dynamic values.
230distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))
231distributeDMapOverDyn dm = case DMap.toList dm of
232 [] -> return $ constDyn DMap.empty
233 [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v
234 _ -> do
235 let edmPre = merge $ rewrapDMap updated dm
236 edm :: Event t (DMap k) = flip push edmPre $ \o -> return . Just =<< do
237 let f _ = \case
238 This origDyn -> sample $ current origDyn
239 That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"
240 These _ (Identity newVal) -> return newVal
241 sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)
242 dm0 :: Behavior t (DMap k) = pull $ do
243 liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv
244 bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm
245 let bdm = pull $ sample =<< sample bbdm
246 return $ Dynamic bdm edm
248-- | Merge two 'Dynamic's into a new one using the provided
249-- function. The new 'Dynamic' changes its value each time one of the
250-- original 'Dynamic's changes its value.
251combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
252combineDyn f da db = do
253 let eab = align (updated da) (updated db)
254 ec = flip push eab $ \o -> do
255 (a, b) <- case o of
256 This a -> do
257 b <- sample $ current db
258 return (a, b)
259 That b -> do
260 a <- sample $ current da
261 return (a, b)
262 These a b -> return (a, b)
263 return $ Just $ f a b
264 c0 :: Behavior t c = pull $ liftM2 f (sample $ current da) (sample $ current db)
265 bbc :: Behavior t (Behavior t c) <- hold c0 $ fmap constant ec
266 let bc :: Behavior t c = pull $ sample =<< sample bbc
267 return $ Dynamic bc ec
269{-
270tagInnerDyn :: Reflex t => Event t (Dynamic t a) -> Event t a
271tagInnerDyn e =
272 let eSlow = push (liftM Just . sample . current) e
273 eFast = coincidence $ fmap updated e
274 in leftmost [eFast, eSlow]
275-}
277-- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value
278-- of the inner 'Dynamic'.
279joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a
280joinDyn dd =
281 let b' = pull $ sample . current =<< sample (current dd)
282 eOuter :: Event t a = pushAlways (sample . current) $ updated dd
283 eInner :: Event t a = switch $ fmap updated (current dd)
284 eBoth :: Event t a = coincidence $ fmap updated (updated dd)
285 e' = leftmost [eBoth, eOuter, eInner]
286 in Dynamic b' e'
288--TODO: Generalize this to functors other than Maps
289-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
290-- with the current values of the 'Dynamic's in a map.
291joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
292joinDynThroughMap dd =
293 let b' = pull $ mapM (sample . current) =<< sample (current dd)
294 eOuter :: Event t (Map k a) = pushAlways (mapM (sample . current)) $ updated dd
295 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
296 readNonFiring :: MonadSample t m => These (Dynamic t a) a -> m a
297 readNonFiring = \case
298 This d -> sample $ current d
299 That a -> return a
300 These _ a -> return a
301 eBoth :: Event t (Map k a) = coincidence $ fmap (\m -> pushAlways (mapM readNonFiring . align m) $ mergeMap $ fmap updated m) (updated dd)
302 e' = leftmost [eBoth, eOuter, eInner]
303 in Dynamic b' e'
305-- | Print the value of the 'Dynamic' on each change and prefix it
306-- with the provided string. This should /only/ be used for debugging.
307--
308-- Note: Just like Debug.Trace.trace, the value will only be shown if something
309-- else in the system is depending on it.
310traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
311traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
313-- | Print the result of applying the provided function to the value
314-- of the 'Dynamic' on each change. This should /only/ be used for
315-- debugging.
316--
317-- Note: Just like Debug.Trace.trace, the value will only be shown if something
318-- else in the system is depending on it.
319traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
320traceDynWith f d =
321 let e' = traceEventWith f $ updated d
322 in Dynamic (current d) e'
324-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
325-- each time the 'Event' occurs.
326--
327-- Note: `tagDyn d e` differs from `tag (current d) e` in the case that `e` is firing
328-- at the same time that `d` is changing. With `tagDyn d e`, the *new* value of `d`
329-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value
330-- will be used, since the 'Behavior' won't be updated until the end of the frame.
331-- Additionally, this means that the output 'Event' may not be used to directly change
332-- the input 'Dynamic', because that would mean its value depends on itself. When creating
333-- cyclic data flows, generally `tag (current d) e` is preferred.
334tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
335tagDyn = attachDynWith const
337-- | Attach the current value of the 'Dynamic' to the value of the
338-- 'Event' each time it occurs.
339--
340-- Note: `attachDyn d` is not the same as `attach (current d)`. See 'tagDyn' for details.
341attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
342attachDyn = attachDynWith (,)
344-- | Combine the current value of the 'Dynamic' with the value of the
345-- 'Event' each time it occurs.
346--
347-- Note: `attachDynWith f d` is not the same as `attachWith f (current d)`. See 'tagDyn' for details.
348attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
349attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b
351-- | Create a new 'Event' by combining the value at each occurence
352-- with the current value of the 'Dynamic' value and possibly
353-- filtering if the combining function returns 'Nothing'.
354--
355-- Note: `attachDynWithMaybe f d` is not the same as `attachWithMaybe f (current d)`. See 'tagDyn' for details.
356attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
357attachDynWithMaybe f d e =
358 let e' = attach (current d) e
359 in fforMaybe (align e' $ updated d) $ \case
360 This (a, b) -> f a b -- Only the tagging event is firing, so use that
361 These (_, b) a -> f a b -- Both events are firing, so use the newer value
362 That _ -> Nothing -- The tagging event isn't firing, so don't fire
364--------------------------------------------------------------------------------
365-- Demux
366--------------------------------------------------------------------------------
368-- | Represents a time changing value together with an 'EventSelector'
369-- that can efficiently detect when the underlying Dynamic has a particular value.
370-- This is useful for representing data like the current selection of a long list.
371--
372-- Semantically,
373-- > getDemuxed (demux d) k === mapDyn (== k) d
374-- However, the when getDemuxed is used multiple times, the complexity is only /O(log(n))/,
375-- rather than /O(n)/ for mapDyn.
376data Demux t k = Demux { demuxValue :: Behavior t k
377 , demuxSelector :: EventSelector t (Const2 k Bool)
378 }
380-- | 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'.
381demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
382demux 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))
384--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
385-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)
386-- mapping over the original 'Dynamic' and checking whether it is equal to the given key.
387getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
388getDemuxed d k = do
389 let e = select (demuxSelector d) (Const2 k)
390 bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e
391 let b = pull $ join $ sample bb
392 return $ Dynamic b e
394--------------------------------------------------------------------------------
395-- collectDyn
396--------------------------------------------------------------------------------
398--TODO: This whole section is badly in need of cleanup
400data FHList f l where
401 FHNil :: FHList f '[]
402 FHCons :: f e -> FHList f l -> FHList f (e ': l)
404instance GEq (HListPtr l) where
405 HHeadPtr `geq` HHeadPtr = Just Refl
406 HHeadPtr `geq` HTailPtr _ = Nothing
407 HTailPtr _ `geq` HHeadPtr = Nothing
408 HTailPtr a `geq` HTailPtr b = a `geq` b
410instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
411 HHeadPtr `gcompare` HHeadPtr = GEQ
412 HHeadPtr `gcompare` HTailPtr _ = GLT
413 HTailPtr _ `gcompare` HHeadPtr = GGT
414 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
416data HListPtr l a where
417 HHeadPtr :: HListPtr (h ': t) h
418 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
420fhlistToDMap :: forall f l. FHList f l -> DMap (WrapArg f (HListPtr l))
421fhlistToDMap = DMap.fromList . go
422 where go :: forall l'. FHList f l' -> [DSum (WrapArg f (HListPtr l'))]
423 go = \case
424 FHNil -> []
425 FHCons h t -> (WrapArg HHeadPtr :=> h) : map (\(WrapArg p :=> v) -> WrapArg (HTailPtr p) :=> v) (go t)
427class RebuildSortedHList l where
428 rebuildSortedFHList :: [DSum (WrapArg f (HListPtr l))] -> FHList f l
429 rebuildSortedHList :: [DSum (HListPtr l)] -> HList l
431instance RebuildSortedHList '[] where
432 rebuildSortedFHList l = case l of
433 [] -> FHNil
434 _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
435 rebuildSortedHList l = case l of
436 [] -> HNil
437 _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"
439instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
440 rebuildSortedFHList l = case l of
441 ((WrapArg HHeadPtr :=> h) : t) -> FHCons h $ rebuildSortedFHList $ map (\(WrapArg (HTailPtr p) :=> v) -> WrapArg p :=> v) t
442 _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
443 rebuildSortedHList l = case l of
444 ((HHeadPtr :=> h) : t) -> HCons h $ rebuildSortedHList $ map (\(HTailPtr p :=> v) -> p :=> v) t
445 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
447dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) -> HList l
448dmapToHList = rebuildSortedHList . DMap.toList
450distributeFHListOverDyn :: forall t m l. (Reflex t, MonadHold t m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
451distributeFHListOverDyn l = mapDyn dmapToHList =<< distributeDMapOverDyn (fhlistToDMap l)
452{-
453distributeFHListOverDyn l = do
454 let ec = undefined
455 c0 = pull $ sequenceFHList $ natMap (sample . current) l
456 bbc <- hold c0 $ fmap constant ec
457 let bc = pull $ sample =<< sample bbc
458 return $ Dynamic bc ec
459-}
461class AllAreFunctors (f :: a -> *) (l :: [a]) where
462 type FunctorList f l :: [*]
463 toFHList :: HList (FunctorList f l) -> FHList f l
464 fromFHList :: FHList f l -> HList (FunctorList f l)
466instance AllAreFunctors f '[] where
467 type FunctorList f '[] = '[]
468 toFHList l = case l of
469 HNil -> FHNil
470 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
471 fromFHList FHNil = HNil
473instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
474 type FunctorList f (h ': t) = f h ': FunctorList f t
475 toFHList l = case l of
476 a `HCons` b -> a `FHCons` toFHList b
477 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
478 fromFHList (a `FHCons` b) = a `HCons` fromFHList b
480collectDyn :: ( RebuildSortedHList (HListElems b)
481 , IsHList a, IsHList b
482 , AllAreFunctors (Dynamic t) (HListElems b)
483 , Reflex t, MonadHold t m
484 , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
485 ) => a -> m (Dynamic t b)
486collectDyn ds =
487 mapDyn fromHList =<< distributeFHListOverDyn (toFHList $ toHList ds)
489-- Poor man's Generic
490class IsHList a where
491 type HListElems a :: [*]
492 toHList :: a -> HList (HListElems a)
493 fromHList :: HList (HListElems a) -> a
495instance IsHList (a, b) where
496 type HListElems (a, b) = [a, b]
497 toHList (a, b) = hBuild a b
498 fromHList l = case l of
499 a `HCons` b `HCons` HNil -> (a, b)
500 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
502instance IsHList (a, b, c, d) where
503 type HListElems (a, b, c, d) = [a, b, c, d]
504 toHList (a, b, c, d) = hBuild a b c d
505 fromHList l = case l of
506 a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
507 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
509instance IsHList (a, b, c, d, e, f) where
510 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
511 toHList (a, b, c, d, e, f) = hBuild a b c d e f
512 fromHList l = case l of
513 a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
514 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139