git.iko.soy/patch
on dc90dd9 help sign in
patch/src/Reflex/Pure.hs
185 lines 7.1 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.Maybe
38import Data.MemoTrie
39import Data.Monoid
40import Data.Type.Coercion
41import Reflex.Class
43-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
44-- with the type @t@.
45data Pure t
47-- | The Enum instance of t must be dense: for all x :: t, there must not exist
48-- any y :: t such that pred x < y < x. The HasTrie instance will be used
49-- exclusively to memoize functions of t, not for any of its other capabilities.
50instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
52 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
53 newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
54 newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
55 newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }
57 type PushM (Pure t) = (->) t
58 type PullM (Pure t) = (->) t
60 never :: Event (Pure t) a
61 never = Event $ \_ -> Nothing
63 constant :: a -> Behavior (Pure t) a
64 constant x = Behavior $ \_ -> x
66 push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
67 push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
69 pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
70 pushCheap = push
72 pull :: PullM (Pure t) a -> Behavior (Pure t) a
73 pull = Behavior . memo
75 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
76 -- warning because the GCompare instance is not used; however, removing the
77 -- GCompare instance produces a different warning, due to that constraint
78 -- being present in the original class definition
80 --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
81 merge events = Event $ memo $ \t ->
82 let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
83 in if DMap.null currentOccurrences
84 then Nothing
85 else Just currentOccurrences
87 fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
88 fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
90 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
91 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
93 coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
94 coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
96 current :: Dynamic (Pure t) a -> Behavior (Pure t) a
97 current d = Behavior $ \t -> fst $ unDynamic d t
99 updated :: Dynamic (Pure t) a -> Event (Pure t) a
100 updated d = Event $ \t -> snd $ unDynamic d t
102 unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
103 unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
105 -- See UNUSED_CONSTRAINT, above.
107 --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
108 --a) -> Incremental (Pure t) p a
109 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
111 mergeIncremental i = Event $ \t ->
112 let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
113 in if DMap.null results
114 then Nothing
115 else Just results
117 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
119 updatedIncremental i = Event $ \t -> snd $ unIncremental i t
121 incrementalToDynamic i = Dynamic $ \t ->
122 let (old, mPatch) = unIncremental i t
123 e = case mPatch of
124 Nothing -> Nothing
125 Just patch -> apply patch old
126 in (old, e)
127 behaviorCoercion Coercion = Coercion
128 eventCoercion Coercion = Coercion
129 dynamicCoercion Coercion = Coercion
131instance Functor (Dynamic (Pure t)) where
132 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
133 in (f cur, fmap f upd)
135instance Applicative (Dynamic (Pure t)) where
136 pure a = Dynamic $ \_ -> (a, Nothing)
137 (<*>) = ap
139instance Monad (Dynamic (Pure t)) where
140 return = pure
141 (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
142 let (curX :: a, updX :: Maybe a) = unDynamic x t
143 (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
144 (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
145 Nothing -> (Nothing, Nothing)
146 Just nextX -> let (c, u) = unDynamic (f nextX) t
147 in (Just c, u)
148 in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
150instance MonadSample (Pure t) ((->) t) where
152 sample :: Behavior (Pure t) a -> (t -> a)
153 sample = unBehavior
155instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
157 hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
158 hold initialValue e initialTime = Behavior f
159 where f = memo $ \sampleTime ->
160 -- Really, the sampleTime should never be prior to the initialTime,
161 -- because that would mean the Behavior is being sampled before
162 -- being created.
163 if sampleTime <= initialTime
164 then initialValue
165 else let lastTime = pred sampleTime
166 in fromMaybe (f lastTime) $ unEvent e lastTime
168 holdDyn :: a -> Event (Pure t) a -> t -> Dynamic (Pure t) a
169 holdDyn initialValue e initialTime =
170 let Behavior f = hold initialValue e initialTime
171 in Dynamic $ \t -> (f t, unEvent e t)
173 holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
174 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
175 where f = memo $ \sampleTime ->
176 -- Really, the sampleTime should never be prior to the initialTime,
177 -- because that would mean the Behavior is being sampled before
178 -- being created.
179 if sampleTime <= initialTime
180 then initialValue
181 else let lastTime = pred sampleTime
182 lastValue = f lastTime
183 in case unEvent e lastTime of
184 Nothing -> lastValue
185 Just x -> fromMaybe lastValue $ apply x lastValue