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