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