git.iko.soy/patch
on 5d9ce23 help sign in
patch/src/Reflex/Pure.hs
167 lines 6.6 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE EmptyDataDecls #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE InstanceSigs #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
9-- There are two expected orphan instances in this module:
10-- * MonadSample (Pure t) ((->) t)
11-- * MonadHold (Pure t) ((->) t)
12{-# OPTIONS_GHC -fno-warn-orphans #-}
14-- | This module provides a pure implementation of Reflex, which is intended to
15-- serve as a reference for the semantics of the Reflex class. All
16-- implementations of Reflex should produce the same results as this
17-- implementation, although performance and laziness/strictness may differ.
18module Reflex.Pure where
20#if !MIN_VERSION_base(4,8,0)
21import Control.Applicative -- Necessary for GHC 7.8
22#endif
24import Control.Monad
25import Data.Dependent.Map (DMap, GCompare)
26import qualified Data.Dependent.Map as DMap
27import Data.Functor.Identity
28import Data.Maybe
29import Data.MemoTrie
30import Data.Monoid
31import Reflex.Class
33data Pure t
35-- | The Enum instance of t must be dense: for all x :: t, there must not exist
36-- any y :: t such that pred x < y < x. The HasTrie instance will be used
37-- exclusively to memoize functions of t, not for any of its other capabilities.
38instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
40 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
41 newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
42 newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
43 newtype Incremental (Pure t) p a = Incremental { unIncremental :: t -> (a, Maybe (p a)) }
45 type PushM (Pure t) = (->) t
46 type PullM (Pure t) = (->) t
48 never :: Event (Pure t) a
49 never = Event $ \_ -> Nothing
51 constant :: a -> Behavior (Pure t) a
52 constant x = Behavior $ \_ -> x
54 push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
55 push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
57 pull :: PullM (Pure t) a -> Behavior (Pure t) a
58 pull = Behavior . memo
60 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
61 -- warning because the GCompare instance is not used; however, removing the
62 -- GCompare instance produces a different warning, due to that constraint
63 -- being present in the original class definition
65 --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
66 merge events = Event $ memo $ \t ->
67 let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
68 in if DMap.null currentOccurrences
69 then Nothing
70 else Just currentOccurrences
72 fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
73 fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
75 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
76 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
78 coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
79 coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
81 current :: Dynamic (Pure t) a -> Behavior (Pure t) a
82 current d = Behavior $ \t -> fst $ unDynamic d t
84 updated :: Dynamic (Pure t) a -> Event (Pure t) a
85 updated d = Event $ \t -> snd $ unDynamic d t
87 unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
88 unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
90 -- See UNUSED_CONSTRAINT, above.
92 --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
93 --a) -> Incremental (Pure t) p a
94 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
96 mergeIncremental (Incremental f) = Event $ \t ->
97 let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ f t
98 in if DMap.null results
99 then Nothing
100 else Just results
102 currentIncremental (Incremental f) = Behavior $ \t -> fst $ f t
104 updatedIncremental (Incremental f) = Event $ \t -> snd $ f t
106 incrementalToDynamic (Incremental f) = Dynamic $ \t ->
107 let (old, mPatch) = f t
108 e = case mPatch of
109 Nothing -> Nothing
110 Just patch -> apply patch old
111 in (old, e)
113instance Functor (Dynamic (Pure t)) where
114 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
115 in (f cur, fmap f upd)
117instance Applicative (Dynamic (Pure t)) where
118 pure a = Dynamic $ \_ -> (a, Nothing)
119 (<*>) = ap
121instance Monad (Dynamic (Pure t)) where
122 return = pure
123 (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
124 let (curX :: a, updX :: Maybe a) = unDynamic x t
125 (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
126 (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
127 Nothing -> (Nothing, Nothing)
128 Just nextX -> let (c, u) = unDynamic (f nextX) t
129 in (Just c, u)
130 in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
132instance MonadSample (Pure t) ((->) t) where
134 sample :: Behavior (Pure t) a -> (t -> a)
135 sample = unBehavior
137instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
139 hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
140 hold initialValue e initialTime = Behavior f
141 where f = memo $ \sampleTime ->
142 -- Really, the sampleTime should never be prior to the initialTime,
143 -- because that would mean the Behavior is being sampled before
144 -- being created.
145 if sampleTime <= initialTime
146 then initialValue
147 else let lastTime = pred sampleTime
148 in fromMaybe (f lastTime) $ unEvent e lastTime
150 holdDyn :: a -> Event (Pure t) a -> t -> Dynamic (Pure t) a
151 holdDyn initialValue e initialTime =
152 let Behavior f = hold initialValue e initialTime
153 in Dynamic $ \t -> (f t, unEvent e t)
155 holdIncremental :: Patch p => a -> Event (Pure t) (p a) -> t -> Incremental (Pure t) p a
156 holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
157 where f = memo $ \sampleTime ->
158 -- Really, the sampleTime should never be prior to the initialTime,
159 -- because that would mean the Behavior is being sampled before
160 -- being created.
161 if sampleTime <= initialTime
162 then initialValue
163 else let lastTime = pred sampleTime
164 lastValue = f lastTime
165 in case unEvent e lastTime of
166 Nothing -> lastValue
167 Just x -> fromMaybe lastValue $ apply x lastValue