git.iko.soy/patch
on 163c414 help sign in
patch/src/Reflex/Pure.hs
208 lines 8.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 #-}
16-- |
17-- Module: Reflex.Pure
18-- Description:
19-- This module provides a pure implementation of Reflex, which is intended to
20-- serve as a reference for the semantics of the Reflex class. All
21-- implementations of Reflex should produce the same results as this
22-- implementation, although performance and laziness/strictness may differ.
23module Reflex.Pure
24 ( Pure
25 , Behavior (..)
26 , Event (..)
27 , Dynamic (..)
28 , Incremental (..)
29 ) where
31#if !MIN_VERSION_base(4,8,0)
32import Control.Applicative
33#endif
35import Control.Monad
36import Data.Dependent.Map (DMap, GCompare)
37import qualified Data.Dependent.Map as DMap
38import Data.Functor.Identity
39import Data.IntMap (IntMap)
40import qualified Data.IntMap as IntMap
41import Data.Maybe
42import Data.MemoTrie
43import Data.Monoid
44import Data.Type.Coercion
45import Reflex.Class
47-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
48-- with the type @/t/@.
49data Pure t
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 --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
85 merge events = Event $ memo $ \t ->
86 let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
87 in if DMap.null currentOccurrences
88 then Nothing
89 else Just currentOccurrences
91 fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
92 fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
94 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
95 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
97 coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
98 coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
100 current :: Dynamic (Pure t) a -> Behavior (Pure t) a
101 current d = Behavior $ \t -> fst $ unDynamic d t
103 updated :: Dynamic (Pure t) a -> Event (Pure t) a
104 updated d = Event $ \t -> snd $ unDynamic d t
106 unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
107 unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
109 -- See UNUSED_CONSTRAINT, above.
111 --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
112 --a) -> Incremental (Pure t) p a
113 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
115 mergeIncremental = mergeIncrementalImpl
116 mergeIncrementalWithMove = mergeIncrementalImpl
118 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
120 updatedIncremental i = Event $ \t -> snd $ unIncremental i t
122 incrementalToDynamic i = Dynamic $ \t ->
123 let (old, mPatch) = unIncremental i t
124 e = case mPatch of
125 Nothing -> Nothing
126 Just patch -> apply patch old
127 in (old, e)
128 behaviorCoercion Coercion = Coercion
129 eventCoercion Coercion = Coercion
130 dynamicCoercion Coercion = Coercion
132 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
134 mergeIntIncremental = mergeIntIncrementalImpl
136mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
137mergeIncrementalImpl i = Event $ \t ->
138 let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
139 in if DMap.null results
140 then Nothing
141 else Just results
143mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)
144mergeIntIncrementalImpl i = Event $ \t ->
145 let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t
146 in if IntMap.null results
147 then Nothing
148 else Just results
150instance Functor (Dynamic (Pure t)) where
151 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
152 in (f cur, fmap f upd)
154instance Applicative (Dynamic (Pure t)) where
155 pure a = Dynamic $ \_ -> (a, Nothing)
156 (<*>) = ap
158instance Monad (Dynamic (Pure t)) where
159 return = pure
160 (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
161 let (curX :: a, updX :: Maybe a) = unDynamic x t
162 (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
163 (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
164 Nothing -> (Nothing, Nothing)
165 Just nextX -> let (c, u) = unDynamic (f nextX) t
166 in (Just c, u)
167 in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
169instance MonadSample (Pure t) ((->) t) where
171 sample :: Behavior (Pure t) a -> (t -> a)
172 sample = unBehavior
174instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
176 hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
177 hold initialValue e initialTime = Behavior f
178 where f = memo $ \sampleTime ->
179 -- Really, the sampleTime should never be prior to the initialTime,
180 -- because that would mean the Behavior is being sampled before
181 -- being created.
182 if sampleTime <= initialTime
183 then initialValue
184 else let lastTime = pred sampleTime
185 in fromMaybe (f lastTime) $ unEvent e lastTime
187 holdDyn v0 = buildDynamic (return v0)
189 buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a
190 buildDynamic initialValue e initialTime =
191 let Behavior f = hold (initialValue initialTime) e initialTime
192 in Dynamic $ \t -> (f t, unEvent e t)
194 holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
195 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
196 where f = memo $ \sampleTime ->
197 -- Really, the sampleTime should never be prior to the initialTime,
198 -- because that would mean the Behavior is being sampled before
199 -- being created.
200 if sampleTime <= initialTime
201 then initialValue
202 else let lastTime = pred sampleTime
203 lastValue = f lastTime
204 in case unEvent e lastTime of
205 Nothing -> lastValue
206 Just x -> fromMaybe lastValue $ apply x lastValue
208 headE = slowHeadE