git.iko.soy/reflex
on develop help sign in
reflex/src/Reflex/Pure.hs
217 lines 8.3 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE InstanceSigs #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE PolyKinds #-}
11#ifdef USE_REFLEX_OPTIMIZER
12{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
13#endif
15-- There are two expected orphan instances in this module:
16-- * MonadSample (Pure t) ((->) t)
17-- * MonadHold (Pure t) ((->) t)
18{-# OPTIONS_GHC -fno-warn-orphans #-}
19-- |
20-- Module: Reflex.Pure
21-- Description:
22-- This module provides a pure implementation of Reflex, which is intended to
23-- serve as a reference for the semantics of the Reflex class. All
24-- implementations of Reflex should produce the same results as this
25-- implementation, although performance and laziness/strictness may differ.
26module Reflex.Pure
27 ( Pure
28 , Behavior (..)
29 , Event (..)
30 , Dynamic (..)
31 , Incremental (..)
32 ) where
34import Control.Monad
35import Data.Dependent.Map (DMap)
36import Data.GADT.Compare (GCompare)
37import qualified Data.Dependent.Map as DMap
38import Data.IntMap (IntMap)
39import qualified Data.IntMap as IntMap
40import Data.Maybe
41import Data.MemoTrie
42import Data.Monoid
43import Data.Type.Coercion
44import Reflex.Class
45import Data.Kind (Type)
47-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
48-- with the type @/t/@.
49data Pure (t :: Type)
51-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
52-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used
53-- exclusively to memoize functions of @/t/@, not for any of its other capabilities.
54instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
56 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
57 newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
58 newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
59 newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }
61 type PushM (Pure t) = (->) t
62 type PullM (Pure t) = (->) t
64 never :: Event (Pure t) a
65 never = Event $ \_ -> Nothing
67 constant :: a -> Behavior (Pure t) a
68 constant x = Behavior $ \_ -> x
70 push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
71 push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
73 pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
74 pushCheap = push
76 pull :: PullM (Pure t) a -> Behavior (Pure t) a
77 pull = Behavior . memo
79 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
80 -- warning because the GCompare instance is not used; however, removing the
81 -- GCompare instance produces a different warning, due to that constraint
82 -- being present in the original class definition.
84 --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))
85 -- -> DMap k q -> Event (Pure t) (DMap k v)
86 mergeG nt events = Event $ memo $ \t ->
87 let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events
88 in if DMap.null currentOccurrences
89 then Nothing
90 else Just currentOccurrences
92-- The instance signature doeesn't compile, leave commented for documentation
93-- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v
94 fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k
96 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
97 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
99 coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
100 coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
102 current :: Dynamic (Pure t) a -> Behavior (Pure t) a
103 current d = Behavior $ \t -> fst $ unDynamic d t
105 updated :: Dynamic (Pure t) a -> Event (Pure t) a
106 updated d = Event $ \t -> snd $ unDynamic d t
108 unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
109 unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
111 -- See UNUSED_CONSTRAINT, above.
113 --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
114 --a) -> Incremental (Pure t) p a
115 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
117 mergeIncrementalG = mergeIncrementalImpl
118 mergeIncrementalWithMoveG = mergeIncrementalImpl
120 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
122 updatedIncremental i = Event $ \t -> snd $ unIncremental i t
124 incrementalToDynamic i = Dynamic $ \t ->
125 let (old, mPatch) = unIncremental i t
126 e = case mPatch of
127 Nothing -> Nothing
128 Just patch -> apply patch old
129 in (old, e)
130 behaviorCoercion Coercion = Coercion
131 eventCoercion Coercion = Coercion
132 dynamicCoercion Coercion = Coercion
133 incrementalCoercion Coercion Coercion = Coercion
135 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
137 mergeIntIncremental = mergeIntIncrementalImpl
139mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)
140 => (forall a. q a -> Event (Pure t) (v a))
141 -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)
142mergeIncrementalImpl nt i = Event $ \t ->
143 let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t
144 in if DMap.null results
145 then Nothing
146 else Just results
148mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)
149mergeIntIncrementalImpl i = Event $ \t ->
150 let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t
151 in if IntMap.null results
152 then Nothing
153 else Just results
155instance Functor (Dynamic (Pure t)) where
156 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
157 in (f cur, fmap f upd)
159instance Applicative (Dynamic (Pure t)) where
160 pure a = Dynamic $ \_ -> (a, Nothing)
161 (<*>) = ap
163instance Monad (Dynamic (Pure t)) where
164 return = pure
165 (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
166 let (curX :: a, updX :: Maybe a) = unDynamic x t
167 (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
168 (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
169 Nothing -> (Nothing, Nothing)
170 Just nextX -> let (c, u) = unDynamic (f nextX) t
171 in (Just c, u)
172 in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
174instance MonadSample (Pure t) ((->) t) where
176 sample :: Behavior (Pure t) a -> (t -> a)
177 sample = unBehavior
179instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
181 hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
182 hold initialValue e initialTime = Behavior f
183 where f = memo $ \sampleTime ->
184 -- Really, the sampleTime should never be prior to the initialTime,
185 -- because that would mean the Behavior is being sampled before
186 -- being created.
187 if sampleTime <= initialTime
188 then initialValue
189 else let lastTime = pred sampleTime
190 in fromMaybe (f lastTime) $ unEvent e lastTime
192 holdDyn v0 = buildDynamic (return v0)
194 buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a
195 buildDynamic initialValue e initialTime =
196 let Behavior f = hold (initialValue initialTime) e initialTime
197 in Dynamic $ \t -> (f t, unEvent e t)
199 holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
200 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
201 where f = memo $ \sampleTime ->
202 -- Really, the sampleTime should never be prior to the initialTime,
203 -- because that would mean the Behavior is being sampled before
204 -- being created.
205 if sampleTime <= initialTime
206 then initialValue
207 else let lastTime = pred sampleTime
208 lastValue = f lastTime
209 in case unEvent e lastTime of
210 Nothing -> lastValue
211 Just x -> fromMaybe lastValue $ apply x lastValue
213 headE = slowHeadE
214 now t = Event $ guard . (t ==)