git.iko.soy/patch
on 41e8513 help sign in
patch/src/Reflex/Pure.hs
206 lines 8.0 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#ifdef USE_REFLEX_OPTIMIZER
9{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10#endif
12-- There are two expected orphan instances in this module:
13-- * MonadSample (Pure t) ((->) t)
14-- * MonadHold (Pure t) ((->) t)
15{-# OPTIONS_GHC -fno-warn-orphans #-}
17-- | This module provides a pure implementation of Reflex, which is intended to
18-- serve as a reference for the semantics of the Reflex class. All
19-- implementations of Reflex should produce the same results as this
20-- implementation, although performance and laziness/strictness may differ.
21module Reflex.Pure
22 ( Pure
23 , Behavior (..)
24 , Event (..)
25 , Dynamic (..)
26 , Incremental (..)
27 ) where
29#if !MIN_VERSION_base(4,8,0)
30import Control.Applicative
31#endif
33import Control.Monad
34import Data.Dependent.Map (DMap, GCompare)
35import qualified Data.Dependent.Map as DMap
36import Data.Functor.Identity
37import Data.IntMap (IntMap)
38import qualified Data.IntMap as IntMap
39import Data.Maybe
40import Data.MemoTrie
41import Data.Monoid
42import Data.Type.Coercion
43import Reflex.Class
45-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
46-- with the type @t@.
47data Pure t
49-- | The Enum instance of t must be dense: for all x :: t, there must not exist
50-- any y :: t such that pred x < y < x. The HasTrie instance will be used
51-- exclusively to memoize functions of t, not for any of its other capabilities.
52instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
54 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
55 newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
56 newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
57 newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }
59 type PushM (Pure t) = (->) t
60 type PullM (Pure t) = (->) t
62 never :: Event (Pure t) a
63 never = Event $ \_ -> Nothing
65 constant :: a -> Behavior (Pure t) a
66 constant x = Behavior $ \_ -> x
68 push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
69 push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
71 pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
72 pushCheap = push
74 pull :: PullM (Pure t) a -> Behavior (Pure t) a
75 pull = Behavior . memo
77 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
78 -- warning because the GCompare instance is not used; however, removing the
79 -- GCompare instance produces a different warning, due to that constraint
80 -- being present in the original class definition
82 --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
83 merge events = Event $ memo $ \t ->
84 let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
85 in if DMap.null currentOccurrences
86 then Nothing
87 else Just currentOccurrences
89 fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
90 fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
92 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
93 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
95 coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
96 coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
98 current :: Dynamic (Pure t) a -> Behavior (Pure t) a
99 current d = Behavior $ \t -> fst $ unDynamic d t
101 updated :: Dynamic (Pure t) a -> Event (Pure t) a
102 updated d = Event $ \t -> snd $ unDynamic d t
104 unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
105 unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
107 -- See UNUSED_CONSTRAINT, above.
109 --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
110 --a) -> Incremental (Pure t) p a
111 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
113 mergeIncremental = mergeIncrementalImpl
114 mergeIncrementalWithMove = mergeIncrementalImpl
116 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
118 updatedIncremental i = Event $ \t -> snd $ unIncremental i t
120 incrementalToDynamic i = Dynamic $ \t ->
121 let (old, mPatch) = unIncremental i t
122 e = case mPatch of
123 Nothing -> Nothing
124 Just patch -> apply patch old
125 in (old, e)
126 behaviorCoercion Coercion = Coercion
127 eventCoercion Coercion = Coercion
128 dynamicCoercion Coercion = Coercion
130 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
132 mergeIntIncremental = mergeIntIncrementalImpl
134mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
135mergeIncrementalImpl i = Event $ \t ->
136 let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
137 in if DMap.null results
138 then Nothing
139 else Just results
141mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)
142mergeIntIncrementalImpl i = Event $ \t ->
143 let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t
144 in if IntMap.null results
145 then Nothing
146 else Just results
148instance Functor (Dynamic (Pure t)) where
149 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
150 in (f cur, fmap f upd)
152instance Applicative (Dynamic (Pure t)) where
153 pure a = Dynamic $ \_ -> (a, Nothing)
154 (<*>) = ap
156instance Monad (Dynamic (Pure t)) where
157 return = pure
158 (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
159 let (curX :: a, updX :: Maybe a) = unDynamic x t
160 (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
161 (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
162 Nothing -> (Nothing, Nothing)
163 Just nextX -> let (c, u) = unDynamic (f nextX) t
164 in (Just c, u)
165 in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
167instance MonadSample (Pure t) ((->) t) where
169 sample :: Behavior (Pure t) a -> (t -> a)
170 sample = unBehavior
172instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
174 hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
175 hold initialValue e initialTime = Behavior f
176 where f = memo $ \sampleTime ->
177 -- Really, the sampleTime should never be prior to the initialTime,
178 -- because that would mean the Behavior is being sampled before
179 -- being created.
180 if sampleTime <= initialTime
181 then initialValue
182 else let lastTime = pred sampleTime
183 in fromMaybe (f lastTime) $ unEvent e lastTime
185 holdDyn v0 = buildDynamic (return v0)
187 buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a
188 buildDynamic initialValue e initialTime =
189 let Behavior f = hold (initialValue initialTime) e initialTime
190 in Dynamic $ \t -> (f t, unEvent e t)
192 holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
193 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
194 where f = memo $ \sampleTime ->
195 -- Really, the sampleTime should never be prior to the initialTime,
196 -- because that would mean the Behavior is being sampled before
197 -- being created.
198 if sampleTime <= initialTime
199 then initialValue
200 else let lastTime = pred sampleTime
201 lastValue = f lastTime
202 in case unEvent e lastTime of
203 Nothing -> lastValue
204 Just x -> fromMaybe lastValue $ apply x lastValue
206 headE = slowHeadE