2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE NoMonomorphismRestriction #-}
9{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE TypeOperators #-}
14{-# LANGUAGE UndecidableInstances #-}
15module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update
38 , distributeDMapOverDyn
48 -- Things that probably aren't very useful:
51 , distributeFHListOverDyn
56import Prelude hiding (mapM, mapM_)
58import Data.Functor.Misc
61import Control.Applicative ((<*>))
62import Control.Monad hiding (forM, forM_, mapM, mapM_)
63import Control.Monad.Fix
64import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
66import Data.Dependent.Map (DMap)
67import qualified Data.Dependent.Map as DMap
68import Data.Dependent.Sum (DSum (..))
69import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
76data HList (l::[*]) where
78 HCons :: e -> HList l -> HList (e ': l)
82type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]
83type instance HRevApp '[] l = l
84type instance HRevApp (e ': l) l' = HRevApp l (e ': l')
86hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)
88hRevApp (HCons x l) l' = hRevApp l (HCons x l')
90hReverse :: HList l -> HList (HRevApp l '[])
91hReverse l = hRevApp l HNil
93hBuild :: (HBuild' '[] r) => r
96class HBuild' l r where
97 hBuild' :: HList l -> r
99instance (l' ~ HRevApp l '[])
100 => HBuild' l (HList l') where
103instance HBuild' (a ': l) r
104 => HBuild' l (a->r) where
105 hBuild' l x = hBuild' (HCons x l)
107-- | Create a new 'Dynamic' that only signals changes if the values
109nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
111 let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)
112 in unsafeDynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior
114-- | Map a function over a 'Dynamic'.
115mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
116mapDyn f = return . fmap f
118-- | Flipped version of 'mapDyn'.
119forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
122-- | Create a 'Dynamic' using the initial value and change it each
123-- time the 'Event' occurs using a folding function on the previous
124-- value and the value of the 'Event'.
125foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
126foldDyn = accum . flip
128-- | Create a 'Dynamic' using the initial value and change it each
129-- time the 'Event' occurs using a monadic folding function on the
130-- previous value and the value of the 'Event'.
131foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
132foldDynM = accumM . flip
134foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
135foldDynMaybe = accumMaybe . flip
137foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
138foldDynMaybeM = accumMaybeM . flip
140-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
141count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
142count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
144-- | Create a new 'Dynamic' using the initial value that flips its
145-- value every time the 'Event' occurs.
146toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
147toggle = foldDyn (const not)
149-- | Switches to the new 'Event' whenever it receives one. Switching
150-- occurs *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the old and new
151-- inner Events fire simultaneously, the output will fire with the value of the *new* 'Event'.
152switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
153switchPromptlyDyn de =
154 let eLag = switch $ current de
155 eCoincidences = coincidence $ updated de
156 in leftmost [eCoincidences, eLag]
160mergeEventsWith :: Reflex t m => (a -> a -> a) -> Event t a -> Event t a -> m (Event t a)
161mergeEventsWith f ea eb = mapE (mergeThese f) =<< alignEvents ea eb
163firstE :: (Reflex t m) => [Event t a] -> m (Event t a)
164firstE [] = return never
165firstE (h:t) = mergeEventsLeftBiased h =<< firstE t
167concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)
168concatEventsWith _ [] = return never
169concatEventsWith _ [e] = return e
170concatEventsWith f es = mapEM (fmap (foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) . sequenceDmap) <=< mergeEventDMap $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es
171--concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t
173mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)
174mconcatE = concatEventsWith mappend
177-- | Split the 'Dynamic' into two 'Dynamic's, each taking the
178-- respective value of the tuple.
179splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
180splitDyn = return . splitDynPure
182splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b)
183splitDynPure d = (fmap fst d, fmap snd d)
185-- | Merge the 'Dynamic' values using their 'Monoid' instance.
186mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
187mconcatDyn = return . mconcat
189-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of
191distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))
192distributeDMapOverDyn = return . distributeDMapOverDynPure
194distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
195distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
197-- | Merge two 'Dynamic's into a new one using the provided
198-- function. The new 'Dynamic' changes its value each time one of the
199-- original 'Dynamic's changes its value.
200combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
201combineDyn f da db = return $ zipDynWith f da db
203-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:
206-- > person <- Person `mapDyn` dynFirstName
207-- > `apDyn` dynListName
209-- > `apDyn` dynAddress
210apDyn :: forall t m a b. (Reflex t, Monad m)
211 => m (Dynamic t (a -> b))
218joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a
221--TODO: Generalize this to functors other than Maps
222-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
223-- with the current values of the 'Dynamic's in a map.
224joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
225joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure
227-- | Print the value of the 'Dynamic' on each change and prefix it
228-- with the provided string. This should /only/ be used for debugging.
230-- Note: Just like Debug.Trace.trace, the value will only be shown if something
231-- else in the system is depending on it.
232traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
233traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
235-- | Print the result of applying the provided function to the value
236-- of the 'Dynamic' on each change. This should /only/ be used for
239-- Note: Just like Debug.Trace.trace, the value will only be shown if something
240-- else in the system is depending on it.
241traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
243 let e' = traceEventWith f $ updated d
245 x <- sample $ current d
246 trace (f x) $ return x
247 in unsafeBuildDynamic getV0 e'
249-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
250-- each time the 'Event' occurs.
252-- Note: `tagDyn d e` differs from `tag (current d) e` in the case that `e` is firing
253-- at the same time that `d` is changing. With `tagDyn d e`, the *new* value of `d`
254-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value
255-- will be used, since the 'Behavior' won't be updated until the end of the frame.
256-- Additionally, this means that the output 'Event' may not be used to directly change
257-- the input 'Dynamic', because that would mean its value depends on itself. When creating
258-- cyclic data flows, generally `tag (current d) e` is preferred.
259tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
260tagDyn = attachDynWith const
262-- | Attach the current value of the 'Dynamic' to the value of the
263-- 'Event' each time it occurs.
265-- Note: `attachDyn d` is not the same as `attach (current d)`. See 'tagDyn' for details.
266attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
267attachDyn = attachDynWith (,)
269-- | Combine the current value of the 'Dynamic' with the value of the
270-- 'Event' each time it occurs.
272-- Note: `attachDynWith f d` is not the same as `attachWith f (current d)`. See 'tagDyn' for details.
273attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
274attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b
276-- | Create a new 'Event' by combining the value at each occurence
277-- with the current value of the 'Dynamic' value and possibly
278-- filtering if the combining function returns 'Nothing'.
280-- Note: `attachDynWithMaybe f d` is not the same as `attachWithMaybe f (current d)`. See 'tagDyn' for details.
281attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
282attachDynWithMaybe f d e =
283 let e' = attach (current d) e
284 in fforMaybe (align e' $ updated d) $ \case
285 This (a, b) -> f a b -- Only the tagging event is firing, so use that
286 These (_, b) a -> f a b -- Both events are firing, so use the newer value
287 That _ -> Nothing -- The tagging event isn't firing, so don't fire
289--------------------------------------------------------------------------------
291--------------------------------------------------------------------------------
293-- | Represents a time changing value together with an 'EventSelector'
294-- that can efficiently detect when the underlying Dynamic has a particular value.
295-- This is useful for representing data like the current selection of a long list.
298-- > getDemuxed (demux d) k === mapDyn (== k) d
299-- However, the when getDemuxed is used multiple times, the complexity is only /O(log(n))/,
300-- rather than /O(n)/ for mapDyn.
301data Demux t k = Demux { demuxValue :: Behavior t k
302 , demuxSelector :: EventSelector t (Const2 k Bool)
305-- | 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'.
306demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
307demux k = Demux (current k)
308 (fan $ attachWith (\k0 k1 -> if k0 == k1
310 else DMap.fromList [Const2 k0 :=> Identity False,
311 Const2 k1 :=> Identity True])
312 (current k) (updated k))
314--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
315-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)
316-- mapping over the original 'Dynamic' and checking whether it is equal to the given key.
317getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
318getDemuxed d k = return $ demuxed d k
320demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool
322 let e = select (demuxSelector d) (Const2 k)
323 in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e
325--------------------------------------------------------------------------------
327--------------------------------------------------------------------------------
329--TODO: This whole section is badly in need of cleanup
332 FHNil :: FHList f '[]
333 FHCons :: f e -> FHList f l -> FHList f (e ': l)
335instance GEq (HListPtr l) where
336 HHeadPtr `geq` HHeadPtr = Just Refl
337 HHeadPtr `geq` HTailPtr _ = Nothing
338 HTailPtr _ `geq` HHeadPtr = Nothing
339 HTailPtr a `geq` HTailPtr b = a `geq` b
341instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
342 HHeadPtr `gcompare` HHeadPtr = GEQ
343 HHeadPtr `gcompare` HTailPtr _ = GLT
344 HTailPtr _ `gcompare` HHeadPtr = GGT
345 HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
347data HListPtr l a where
348 HHeadPtr :: HListPtr (h ': t) h
349 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
351fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
352fhlistToDMap = DMap.fromList . go
353 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
356 FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> HTailPtr p :=> v) (go t)
358class RebuildSortedHList l where
359 rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l
360 rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l
362instance RebuildSortedHList '[] where
363 rebuildSortedFHList l = case l of
365 _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
366 rebuildSortedHList l = case l of
368 _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"
370instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
371 rebuildSortedFHList l = case l of
372 ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
373 _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
374 rebuildSortedHList l = case l of
375 ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
376 _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
378dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
379dmapToHList = rebuildSortedHList . DMap.toList
381distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
382distributeFHListOverDyn = return . distributeFHListOverDynPure
384distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)
385distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l
387class AllAreFunctors (f :: a -> *) (l :: [a]) where
388 type FunctorList f l :: [*]
389 toFHList :: HList (FunctorList f l) -> FHList f l
390 fromFHList :: FHList f l -> HList (FunctorList f l)
392instance AllAreFunctors f '[] where
393 type FunctorList f '[] = '[]
394 toFHList l = case l of
396#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
397 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
399 fromFHList FHNil = HNil
401instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
402 type FunctorList f (h ': t) = f h ': FunctorList f t
403 toFHList l = case l of
404 a `HCons` b -> a `FHCons` toFHList b
405#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
406 _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
408 fromFHList (a `FHCons` b) = a `HCons` fromFHList b
410collectDyn :: ( RebuildSortedHList (HListElems b)
411 , IsHList a, IsHList b
412 , AllAreFunctors (Dynamic t) (HListElems b)
414 , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
415 ) => a -> m (Dynamic t b)
416collectDyn = return . collectDynPure
418collectDynPure :: ( RebuildSortedHList (HListElems b)
419 , IsHList a, IsHList b
420 , AllAreFunctors (Dynamic t) (HListElems b)
422 , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
423 ) => a -> Dynamic t b
424collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds
428 type HListElems a :: [*]
429 toHList :: a -> HList (HListElems a)
430 fromHList :: HList (HListElems a) -> a
432instance IsHList (a, b) where
433 type HListElems (a, b) = [a, b]
434 toHList (a, b) = hBuild a b
435 fromHList l = case l of
436 a `HCons` b `HCons` HNil -> (a, b)
437#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
438 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
441instance IsHList (a, b, c, d) where
442 type HListElems (a, b, c, d) = [a, b, c, d]
443 toHList (a, b, c, d) = hBuild a b c d
444 fromHList l = case l of
445 a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
446#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
447 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
450instance IsHList (a, b, c, d, e, f) where
451 type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
452 toHList (a, b, c, d, e, f) = hBuild a b c d e f
453 fromHList l = case l of
454 a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
455#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
456 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list