git.iko.soy/patch
on ef4da28 help sign in
patch/src/Reflex/Pure.hs
191 lines 7.4 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 = mergeIncrementalImpl
112 mergeIncrementalWithMove = mergeIncrementalImpl
114 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
116 updatedIncremental i = Event $ \t -> snd $ unIncremental i t
118 incrementalToDynamic i = Dynamic $ \t ->
119 let (old, mPatch) = unIncremental i t
120 e = case mPatch of
121 Nothing -> Nothing
122 Just patch -> apply patch old
123 in (old, e)
124 behaviorCoercion Coercion = Coercion
125 eventCoercion Coercion = Coercion
126 dynamicCoercion Coercion = Coercion
128mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
129mergeIncrementalImpl i = Event $ \t ->
130 let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
131 in if DMap.null results
132 then Nothing
133 else Just results
135instance Functor (Dynamic (Pure t)) where
136 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
137 in (f cur, fmap f upd)
139instance Applicative (Dynamic (Pure t)) where
140 pure a = Dynamic $ \_ -> (a, Nothing)
141 (<*>) = ap
143instance Monad (Dynamic (Pure t)) where
144 return = pure
145 (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
146 let (curX :: a, updX :: Maybe a) = unDynamic x t
147 (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
148 (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
149 Nothing -> (Nothing, Nothing)
150 Just nextX -> let (c, u) = unDynamic (f nextX) t
151 in (Just c, u)
152 in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
154instance MonadSample (Pure t) ((->) t) where
156 sample :: Behavior (Pure t) a -> (t -> a)
157 sample = unBehavior
159instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
161 hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
162 hold initialValue e initialTime = Behavior f
163 where f = memo $ \sampleTime ->
164 -- Really, the sampleTime should never be prior to the initialTime,
165 -- because that would mean the Behavior is being sampled before
166 -- being created.
167 if sampleTime <= initialTime
168 then initialValue
169 else let lastTime = pred sampleTime
170 in fromMaybe (f lastTime) $ unEvent e lastTime
172 holdDyn v0 = buildDynamic (return v0)
174 buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a
175 buildDynamic initialValue e initialTime =
176 let Behavior f = hold (initialValue initialTime) e initialTime
177 in Dynamic $ \t -> (f t, unEvent e t)
179 holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
180 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
181 where f = memo $ \sampleTime ->
182 -- Really, the sampleTime should never be prior to the initialTime,
183 -- because that would mean the Behavior is being sampled before
184 -- being created.
185 if sampleTime <= initialTime
186 then initialValue
187 else let lastTime = pred sampleTime
188 lastValue = f lastTime
189 in case unEvent e lastTime of
190 Nothing -> lastValue
191 Just x -> fromMaybe lastValue $ apply x lastValue