Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 287 lines (220 sloc) 10.773 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286
-----------------------------------------------------------------------------
-- |
-- Module : AFRPEvent
-- Copyright : (c) Yale University, 2003
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : antony@apocalypse.org
-- Stability : provisional
-- Portability : non-portable (uses GHC extensions)
--
-- Definition of AFRP Event type.
--
{-
-- Note on naming conventions used in this module.
--
-- Names here might have to be rethought. It's really a bit messy.
-- In general, the aim has been short and convenient names (like "tag",
-- "attach", "lMerge") and thus we have tried to stay away from suffixing/
-- prefixing conventions. E.g. "Event" as a common suffix would be very
-- verbose.
--
-- However, part of the names come from a desire to stay close to similar
-- functions for the Maybe type. e.g. "event", "fromEvent", "isEvent".
-- In many cases, this use of "Event" can could understood to refer to the
-- *constructor* "Event", not to the type name "Event". Thus this use of
-- event should not be seen as a suffixing-with-type-name convention. But
-- that is obviously not easy to see, and, more over, interpreting "Event"
-- as the name of the type might make equally good or better sense. E.g.
-- "fromEvent" can also be seen as a function taking an event signal,
-- which is a *partial* function on time, to a normal signal. The latter is
-- then undefined when the source event function is undefined.
--
-- In other cases, it has been necessary to somehow stay out of the way of
-- names used by the prelude or other commonly imported modules/modules
-- which could be expected to be used heavily in AFRP code. In those cases
-- a suffix "E" have been added. Examples are "filterE" (exists in Prelude)
-- and "joinE" (exists in Monad). Maybe the suffix isn't necessary in the
-- last case.
--
-- Some functions (actually only one currently, mapFilterE") have got an "E"
-- suffix just because they're closely related (by name or semantics) to one
-- which already has an "E" suffix. Another candidate would be "splitE" to
-- complement "joinE". But events carrying pairs could obviously have other
-- sources than a "joinE", so currently it is called "split".
--
-- 2003-05-19: Actually, have now changed to "splitE" to avoid a clash
-- with the method "split" in the class RandomGen.
--
-- 2003-05-19: What about "gate"? Stands out compared to e.g. "filterE".
--
-- Currently the "E" suffix is considered an exception. Maybe we should use
-- completely different names to avoid the "E" suffix. If the functions
-- are not used that often, "Event" might be approriate. Alternatively the
-- suffix "E" should be adopted globaly (except if the name already contains
-- "event" in some form?).
--
-- Arguably, having both a type "Event" and a constructor "Event" is confusing
-- since there are more than one constructor. But the name "Event" for the
-- constructor is quite apt. It's really the type name that is wrong. But
-- no one has found a better name, and changing it would be a really major
-- undertaking. Yes, the constructor "Event" is not exported, but we still
-- need to talk conceptually about them. On the other hand, if we consider
-- Event-signals as partial functions on time, maybe it isn't so confusing:
-- they just don't have a value between events, so "NoEvent" does not really
-- exist conceptually.
--
-- ToDo:
-- - Either: reveal NoEvent and Event
-- or: introcuce "event = Event", call what's now "event" "fromEvent",
-- and call what's now called "fromEvent" something else, like
-- "unsafeFromEvent"??? Better, dump it! After all, using current
-- names, "fromEvent = event undefined"!
-}
module AFRPEvent where

import AFRPDiagnostics
import AFRPForceable


infixl 8 `tag`, `attach`, `gate`
infixl 7 `joinE`
infixl 6 `lMerge`, `rMerge`, `merge`


------------------------------------------------------------------------------
-- The Event type
------------------------------------------------------------------------------

-- The type Event represents a single possible event occurrence.
-- It is isomorphic to Maybe, but its constructors are not exposed outside
-- the AFRP implementation.
-- There could possibly be further constructors, but note that the NeverEvent-
-- idea does not work, at least not in the current AFRP implementation.
-- Also note that it unfortunately is possible to partially break the
-- abstractions through judicious use of e.g. snap and switching.

data Event a = NoEvent
| Event a


-- Make the NoEvent constructor available. Useful e.g. for initialization,
-- ((-->) & friends), and it's easily available anyway (e.g. mergeEvents []).
noEvent :: Event a
noEvent = NoEvent


-- Suppress any event in the first component of a pair.
noEventFst :: (Event a, b) -> (Event c, b)
noEventFst (_, b) = (NoEvent, b)


-- Suppress any event in the second component of a pair.
noEventSnd :: (a, Event b) -> (a, Event c)
noEventSnd (a, _) = (a, NoEvent)


------------------------------------------------------------------------------
-- Eq instance
------------------------------------------------------------------------------

-- Right now, we could derive this instance. But that could possibly change.

instance Eq a => Eq (Event a) where
    NoEvent == NoEvent = True
    (Event x) == (Event y) = x == y
    _ == _ = False


------------------------------------------------------------------------------
-- Ord instance
------------------------------------------------------------------------------

instance Ord a => Ord (Event a) where
    compare NoEvent NoEvent = EQ
    compare NoEvent (Event _) = LT
    compare (Event _) NoEvent = GT
    compare (Event x) (Event y) = compare x y


------------------------------------------------------------------------------
-- Functor instance
------------------------------------------------------------------------------

instance Functor Event where
    fmap f NoEvent = NoEvent
    fmap f (Event a) = Event (f a)


------------------------------------------------------------------------------
-- Forceable instance
------------------------------------------------------------------------------

instance Forceable a => Forceable (Event a) where
    force ea@NoEvent = ea
    force ea@(Event a) = force a `seq` ea


------------------------------------------------------------------------------
-- Internal utilities for event construction
------------------------------------------------------------------------------

-- These utilities are to be considered strictly internal to AFRP for the
-- time being.

maybeToEvent :: Maybe a -> Event a
maybeToEvent Nothing = NoEvent
maybeToEvent (Just a) = Event a


------------------------------------------------------------------------------
-- Utility functions similar to those available for Maybe
------------------------------------------------------------------------------

-- An event-based version of the maybe function.
event :: a -> (b -> a) -> Event b -> a
event a _ NoEvent = a
event _ f (Event b) = f b

fromEvent :: Event a -> a
fromEvent (Event a) = a
fromEvent NoEvent = usrErr "AFRP" "fromEvent" "Not an event."

isEvent :: Event a -> Bool
isEvent NoEvent = False
isEvent (Event _) = True

isNoEvent :: Event a -> Bool
isNoEvent = not . isEvent


------------------------------------------------------------------------------
-- Event tagging
------------------------------------------------------------------------------

-- Tags an (occurring) event with a value ("replacing" the old value).
tag :: Event a -> b -> Event b
e `tag` b = fmap (const b) e


-- Attaches an extra value to the value of an occurring event.
attach :: Event a -> b -> Event (a, b)
e `attach` b = fmap (\a -> (a, b)) e


------------------------------------------------------------------------------
-- Event merging (disjunction) and joining (conjunction)
------------------------------------------------------------------------------

-- Left-biased event merge.
lMerge :: Event a -> Event a -> Event a
le `lMerge` re = event re Event le


-- Right-biased event merge.
rMerge :: Event a -> Event a -> Event a
le `rMerge` re = event le Event re


-- Unbiased event merge: simultaneous occurrence is an error.
merge :: Event a -> Event a -> Event a
merge = mergeBy (usrErr "AFRP" "merge" "Simultaneous event occurrence.")


-- Event merge paramterezied on the conflict resolution function.
mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a
mergeBy _ NoEvent NoEvent = NoEvent
mergeBy _ le@(Event _) NoEvent = le
mergeBy _ NoEvent re@(Event _) = re
mergeBy resolve (Event l) (Event r) = Event (resolve l r)


-- A generic event merge utility:
mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c)
-> Event a -> Event b -> Event c
mapMerge _ _ _ NoEvent NoEvent = NoEvent
mapMerge lf _ _ (Event l) NoEvent = Event (lf l)
mapMerge _ rf _ NoEvent (Event r) = Event (rf r)
mapMerge _ _ lrf (Event l) (Event r) = Event (lrf l r)

-- Merging of a list of events; foremost event has priority.
mergeEvents :: [Event a] -> Event a
mergeEvents = foldr lMerge NoEvent


-- Collects simultaneous event occurrences; no event if none.
catEvents :: [Event a] -> Event [a]
catEvents eas = case [ a | Event a <- eas ] of
[] -> NoEvent
as -> Event as


-- Join (conjucntion) of two events.
joinE :: Event a -> Event b -> Event (a,b)
joinE NoEvent _ = NoEvent
joinE _ NoEvent = NoEvent
joinE (Event l) (Event r) = Event (l,r)


-- Split event carrying pairs into two events.
splitE :: Event (a,b) -> (Event a, Event b)
splitE NoEvent = (NoEvent, NoEvent)
splitE (Event (a,b)) = (Event a, Event b)


------------------------------------------------------------------------------
-- Event filtering
------------------------------------------------------------------------------

-- Filter out events that don't satisfy some predicate.
filterE :: (a -> Bool) -> Event a -> Event a
filterE p e@(Event a) = if (p a) then e else NoEvent
filterE _ NoEvent = NoEvent


-- Combined event mapping and filtering.
mapFilterE :: (a -> Maybe b) -> Event a -> Event b
mapFilterE _ NoEvent = NoEvent
mapFilterE f (Event a) = case f a of
Nothing -> NoEvent
Just b -> Event b


-- Enable/disable event occurences based on an external condition.
gate :: Event a -> Bool -> Event a
_ `gate` False = NoEvent
e `gate` True = e
Something went wrong with that request. Please try again.