Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 219 lines (168 sloc) 7.799 kb
14e9771 @serras Initial commit
authored
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module : AFRPTask
4 -- Copyright : (c) Yale University, 2003
5 -- License : BSD-style (see the file LICENSE)
6 --
7 -- Maintainer : antony@apocalypse.org
8 -- Stability : provisional
9 -- Portability : non-portable (uses GHC extensions)
10 --
11 -- Task abstraction on top of signal transformers.
12 --
13 module AFRPTask (
14 Task,
15 mkTask, -- :: SF a (b, Event c) -> Task a b c
16 runTask, -- :: Task a b c -> SF a (Either b c) -- Might change.
17 runTask_, -- :: Task a b c -> SF a b
18 taskToSF, -- :: Task a b c -> SF a (b, Event c) -- Might change.
19 constT, -- :: b -> Task a b c
20 sleepT, -- :: Time -> b -> Task a b ()
21 snapT, -- :: Task a b a
22 timeOut, -- :: Task a b c -> Time -> Task a b (Maybe c)
23 abortWhen, -- :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
24 repeatUntil,-- :: Monad m => m a -> (a -> Bool) -> m a
25 for, -- :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()
26 forAll, -- :: Monad m => [a] -> (a -> m b) -> m ()
27 forEver -- :: Monad m => m a -> m b
28 ) where
29
30 import AFRP
31 import AFRPUtilities (snap)
32 import AFRPDiagnostics
33
34 infixl 0 `timeOut`, `abortWhen`, `repeatUntil`
35
36
37 ------------------------------------------------------------------------------
38 -- The Task type
39 ------------------------------------------------------------------------------
40
41 -- CPS-based representation allowing a termination to be detected.
42 -- (Note the rank 2 polymorphic type!)
43 -- The representation can be changed if necessary, but the Monad laws
44 -- follow trivially in this case.
45 newtype Task a b c =
46 Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d))
47
48
49 unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d))
50 unTask (Task f) = f
51
52
53 mkTask :: SF a (b, Event c) -> Task a b c
54 mkTask st = Task (switch (st >>> first (arr Left)))
55
56
57 -- "Runs" a task (unusually bad name?). The output from the resulting
58 -- signal transformer is tagged with Left while the underlying task is
59 -- running. Once the task has terminated, the output goes constant with
60 -- the value Right x, where x is the value of the terminating event.
61 runTask :: Task a b c -> SF a (Either b c)
62 runTask tk = (unTask tk) (\c -> constant (Right c))
63
64
65 -- Runs a task. The output becomes undefined once the underlying task has
66 -- terminated. Convenient e.g. for tasks which are known not to terminate.
67 runTask_ :: Task a b c -> SF a b
68 runTask_ tk = runTask tk
69 >>> arr (either id (usrErr "AFRPTask" "runTask_"
70 "Task terminated!"))
71
72
73 -- Seems as if the following is convenient after all. Suitable name???
74 -- Maybe that implies a representation change for Tasks?
75 -- Law: mkTask (taskToSF task) = task (but not (quite) vice versa.)
76 taskToSF :: Task a b c -> SF a (b, Event c)
77 taskToSF tk = runTask tk
78 >>> (arr (either id ((usrErr "AFRPTask" "runTask_"
79 "Task terminated!")))
80 &&& edgeBy isEdge (Left undefined))
81 where
82 isEdge (Left _) (Left _) = Nothing
83 isEdge (Left _) (Right c) = Just c
84 isEdge (Right _) (Right _) = Nothing
85 isEdge (Right _) (Left _) = Nothing
86
87
88 ------------------------------------------------------------------------------
89 -- Monad instance
90 ------------------------------------------------------------------------------
91
92 instance Monad (Task a b) where
93 tk >>= f = Task (\k -> (unTask tk) (\c -> unTask (f c) k))
94 return x = Task (\k -> k x)
95
96 {-
97 Let's check the monad laws:
98
99 t >>= return
100 = \k -> t (\c -> return c k)
101 = \k -> t (\c -> (\x -> \k -> k x) c k)
102 = \k -> t (\c -> (\x -> \k' -> k' x) c k)
103 = \k -> t (\c -> k c)
104 = \k -> t k
105 = t
106 QED
107
108 return x >>= f
109 = \k -> (return x) (\c -> f c k)
110 = \k -> (\k -> k x) (\c -> f c k)
111 = \k -> (\k' -> k' x) (\c -> f c k)
112 = \k -> (\c -> f c k) x
113 = \k -> f x k
114 = f x
115 QED
116
117 (t >>= f) >>= g
118 = \k -> (t >>= f) (\c -> g c k)
119 = \k -> (\k' -> t (\c' -> f c' k')) (\c -> g c k)
120 = \k -> t (\c' -> f c' (\c -> g c k))
121 = \k -> t (\c' -> (\x -> \k' -> f x (\c -> g c k')) c' k)
122 = \k -> t (\c' -> (\x -> f x >>= g) c' k)
123 = t >>= (\x -> f x >>= g)
124 QED
125
126 No surprises (obviously, since this is essentially just the CPS monad).
127 -}
128
129
130 ------------------------------------------------------------------------------
131 -- Basic tasks
132 ------------------------------------------------------------------------------
133
134 -- Non-terminating task with constant output b.
135 constT :: b -> Task a b c
136 constT b = mkTask (constant b &&& never)
137
138
139 -- "Sleeps" for t seconds with constant output b.
140 sleepT :: Time -> b -> Task a b ()
141 sleepT t b = mkTask (constant b &&& after t ())
142
143
144 -- Takes a "snapshot" of the input and terminates immediately with the input
145 -- value as the result. No time passes; law:
146 --
147 -- snapT >> snapT = snapT
148 --
149 snapT :: Task a b a
150 snapT = mkTask (constant (intErr "AFRPTask" "snapT" "Bad switch?") &&& snap)
151
152
153 ------------------------------------------------------------------------------
154 -- Basic tasks combinators
155 ------------------------------------------------------------------------------
156
157 -- Impose a time out on a task.
158 timeOut :: Task a b c -> Time -> Task a b (Maybe c)
159 tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux)
160 where
161 aux ((b, ec), et) = (b, (lMerge (fmap Just ec)
162 (fmap (const Nothing) et)))
163
164
165 -- Run a "guarding" event source (SF a (Event b)) in parallel with a
166 -- (possibly non-terminating) task. The task will be aborted at the
167 -- first occurrence of the event source (if it has not terminated itself
168 -- before that). Useful for separating sequencing and termination concerns.
169 -- E.g. we can do something "useful", but in parallel watch for a (exceptional)
170 -- condition which should terminate that activity, whithout having to check
171 -- for that condition explicitly during each and every phase of the activity.
172 -- Example: tsk `abortWhen` lbp
173 abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d)
174 tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux)
175 where
176 aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed)))
177
178
179 ------------------------------------------------------------------------------
180 -- Loops
181 ------------------------------------------------------------------------------
182
183 -- These are general monadic combinators. Maybe they don't really belong here.
184
185 -- Repeat m until result satisfies the predicate p
186 repeatUntil :: Monad m => m a -> (a -> Bool) -> m a
187 m `repeatUntil` p = m >>= \x -> if not (p x) then repeatUntil m p else return x
188
189
190 -- C-style for-loop.
191 -- Example: for 0 (+1) (>=10) ...
192 for :: Monad m => a -> (a -> a) -> (a -> Bool) -> m b -> m ()
193 for i f p m = if p i then m >> for (f i) f p m else return ()
194
195
196 -- Perform the monadic operation for each element in the list.
197 forAll :: Monad m => [a] -> (a -> m b) -> m ()
198 forAll = flip mapM_
199
200
201 -- Repeat m for ever.
202 forEver :: Monad m => m a -> m b
203 forEver m = m >> forEver m
204
205
206 -- Alternatives/other potentially useful signatures:
207 -- until :: a -> (a -> M a) -> (a -> Bool) -> M a
208 -- for: a -> b -> (a -> b -> a) -> (a -> b -> Bool) -> (a -> b -> M b) -> M b
209 -- while??? It could be:
210 -- while :: a -> (a -> Bool) -> (a -> M a) -> M a
211
212
213 ------------------------------------------------------------------------------
214 -- Monad transformers?
215 ------------------------------------------------------------------------------
216
217 -- What about monad transformers if we want to compose this monad with
218 -- other capabilities???
Something went wrong with that request. Please try again.