git.iko.soy/reflex
on eeeae5f help sign in
reflex/src/Reflex/Pure.hs
217 lines 8.3 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
34#if !MIN_VERSION_base(4,8,0)
35import Control.Applicative
36#endif
38import Control.Monad
39import Data.Dependent.Map (DMap, GCompare)
40import qualified Data.Dependent.Map as DMap
41import Data.Functor.Identity
42import Data.IntMap (IntMap)
43import qualified Data.IntMap as IntMap
44import Data.Maybe
45import Data.MemoTrie
46import Data.Monoid
47import Data.Type.Coercion
48import Reflex.Class
49import Data.Kind (Type)
51-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
52-- with the type @/t/@.
53data Pure (t :: Type)
55-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
56-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used
57-- exclusively to memoize functions of @/t/@, not for any of its other capabilities.
58instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
60 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
61 newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
62 newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
63 newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }
65 type PushM (Pure t) = (->) t
66 type PullM (Pure t) = (->) t
68 never :: Event (Pure t) a
69 never = Event $ \_ -> Nothing
71 constant :: a -> Behavior (Pure t) a
72 constant x = Behavior $ \_ -> x
74 push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
75 push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
77 pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
78 pushCheap = push
80 pull :: PullM (Pure t) a -> Behavior (Pure t) a
81 pull = Behavior . memo
83 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
84 -- warning because the GCompare instance is not used; however, removing the
85 -- GCompare instance produces a different warning, due to that constraint
86 -- being present in the original class definition.
88 --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))
89 -- -> DMap k q -> Event (Pure t) (DMap k v)
90 mergeG nt events = Event $ memo $ \t ->
91 let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events
92 in if DMap.null currentOccurrences
93 then Nothing
94 else Just currentOccurrences
96-- The instance signature doeesn't compile, leave commented for documentation
97-- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v
98 fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k
100 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
101 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
103 coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
104 coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
106 current :: Dynamic (Pure t) a -> Behavior (Pure t) a
107 current d = Behavior $ \t -> fst $ unDynamic d t
109 updated :: Dynamic (Pure t) a -> Event (Pure t) a
110 updated d = Event $ \t -> snd $ unDynamic d t
112 unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
113 unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
115 -- See UNUSED_CONSTRAINT, above.
117 --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
118 --a) -> Incremental (Pure t) p a
119 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
121 mergeIncrementalG = mergeIncrementalImpl
122 mergeIncrementalWithMoveG = mergeIncrementalImpl
124 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
126 updatedIncremental i = Event $ \t -> snd $ unIncremental i t
128 incrementalToDynamic i = Dynamic $ \t ->
129 let (old, mPatch) = unIncremental i t
130 e = case mPatch of
131 Nothing -> Nothing
132 Just patch -> apply patch old
133 in (old, e)
134 behaviorCoercion Coercion = Coercion
135 eventCoercion Coercion = Coercion
136 dynamicCoercion Coercion = Coercion
137 incrementalCoercion Coercion Coercion = Coercion
139 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
141 mergeIntIncremental = mergeIntIncrementalImpl
143mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)
144 => (forall a. q a -> Event (Pure t) (v a))
145 -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)
146mergeIncrementalImpl nt i = Event $ \t ->
147 let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t
148 in if DMap.null results
149 then Nothing
150 else Just results
152mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)
153mergeIntIncrementalImpl i = Event $ \t ->
154 let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t
155 in if IntMap.null results
156 then Nothing
157 else Just results
159instance Functor (Dynamic (Pure t)) where
160 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
161 in (f cur, fmap f upd)
163instance Applicative (Dynamic (Pure t)) where
164 pure a = Dynamic $ \_ -> (a, Nothing)
165 (<*>) = ap
167instance Monad (Dynamic (Pure t)) where
168 return = pure
169 (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
170 let (curX :: a, updX :: Maybe a) = unDynamic x t
171 (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
172 (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
173 Nothing -> (Nothing, Nothing)
174 Just nextX -> let (c, u) = unDynamic (f nextX) t
175 in (Just c, u)
176 in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
178instance MonadSample (Pure t) ((->) t) where
180 sample :: Behavior (Pure t) a -> (t -> a)
181 sample = unBehavior
183instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
185 hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
186 hold initialValue e initialTime = Behavior f
187 where f = memo $ \sampleTime ->
188 -- Really, the sampleTime should never be prior to the initialTime,
189 -- because that would mean the Behavior is being sampled before
190 -- being created.
191 if sampleTime <= initialTime
192 then initialValue
193 else let lastTime = pred sampleTime
194 in fromMaybe (f lastTime) $ unEvent e lastTime
196 holdDyn v0 = buildDynamic (return v0)
198 buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a
199 buildDynamic initialValue e initialTime =
200 let Behavior f = hold (initialValue initialTime) e initialTime
201 in Dynamic $ \t -> (f t, unEvent e t)
203 holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
204 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
205 where f = memo $ \sampleTime ->
206 -- Really, the sampleTime should never be prior to the initialTime,
207 -- because that would mean the Behavior is being sampled before
208 -- being created.
209 if sampleTime <= initialTime
210 then initialValue
211 else let lastTime = pred sampleTime
212 lastValue = f lastTime
213 in case unEvent e lastTime of
214 Nothing -> lastValue
215 Just x -> fromMaybe lastValue $ apply x lastValue
217 headE = slowHeadE