{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-- |
-- Module      : FRP.Yampa.Event
-- Copyright   : (c) Ivan Perez, 2014-2022
--               (c) George Giorgidze, 2007-2012
--               (c) Henrik Nilsson, 2005-2006
--               (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004
-- License     : BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  : ivan.perez@keera.co.uk
-- Stability   : provisional
-- Portability : portable
--
-- Events in Yampa represent discrete time-signals, meaning those that do not
-- change continuously. Examples of event-carrying signals would be mouse
-- clicks (in between clicks it is assumed that there is no click), some
-- keyboard events, button presses on wiimotes or window-manager events.
--
-- The type 'Event' is isomorphic to 'Maybe' (@Event a = NoEvent | Event a@)
-- but, semantically, a 'Maybe'-carrying signal could change continuously,
-- whereas an 'Event'-carrying signal should not: for two events in subsequent
-- samples, there should be an small enough sampling frequency such that we
-- sample between those two samples and there are no 'Event's between them.
-- Nevertheless, no mechanism in Yampa will check this or misbehave if this
-- assumption is violated.
--
-- Events are essential for many other Yampa constructs, like switches (see
-- 'FRP.Yampa.Switches.switch' for details).
module FRP.Yampa.Event where

import           Control.Applicative
import           Control.DeepSeq     (NFData (..))
import qualified Control.Monad.Fail  as Fail

import FRP.Yampa.Diagnostics

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

-- * The Event type

-- | A single possible event occurrence, that is, a value that may or may
-- not occur. Events are used to represent values that are not produced
-- continuously, such as mouse clicks (only produced when the mouse is clicked,
-- as opposed to mouse positions, which are always defined).
data Event a = NoEvent | Event a deriving (Int -> Event a -> ShowS
forall a. Show a => Int -> Event a -> ShowS
forall a. Show a => [Event a] -> ShowS
forall a. Show a => Event a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event a] -> ShowS
$cshowList :: forall a. Show a => [Event a] -> ShowS
show :: Event a -> String
$cshow :: forall a. Show a => Event a -> String
showsPrec :: Int -> Event a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Event a -> ShowS
Show)

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

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

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

-- | Eq instance (equivalent to derived instance)
instance Eq a => Eq (Event a) where
  -- | Equal if both NoEvent or both Event carrying equal values.
  Event a
NoEvent   == :: Event a -> Event a -> Bool
== Event a
NoEvent   = Bool
True
  (Event a
x) == (Event a
y) = a
x forall a. Eq a => a -> a -> Bool
== a
y
  Event a
_         == Event a
_         = Bool
False

-- | Ord instance (equivalent to derived instance)
instance Ord a => Ord (Event a) where
  -- | NoEvent is smaller than Event, Event x < Event y if x < y
  compare :: Event a -> Event a -> Ordering
compare Event a
NoEvent   Event a
NoEvent   = Ordering
EQ
  compare Event a
NoEvent   (Event a
_) = Ordering
LT
  compare (Event a
_) Event a
NoEvent   = Ordering
GT
  compare (Event a
x) (Event a
y) = forall a. Ord a => a -> a -> Ordering
compare a
x a
y

-- | Functor instance (could be derived).
instance Functor Event where
  -- | Apply function to value carried by 'Event', if any.
  fmap :: forall a b. (a -> b) -> Event a -> Event b
fmap a -> b
_ Event a
NoEvent   = forall a. Event a
NoEvent
  fmap a -> b
f (Event a
a) = forall a. a -> Event a
Event (a -> b
f a
a)

-- | Applicative instance (similar to 'Maybe').
instance Applicative Event where
  -- | Wrap a pure value in an 'Event'.
  pure :: forall a. a -> Event a
pure = forall a. a -> Event a
Event
  -- | If any value (function or arg) is 'NoEvent', everything is.
  Event (a -> b)
NoEvent <*> :: forall a b. Event (a -> b) -> Event a -> Event b
<*> Event a
_ = forall a. Event a
NoEvent
  Event a -> b
f <*> Event a
x = a -> b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event a
x

-- | Monad instance
instance Monad Event where
  -- | Combine events, return 'NoEvent' if any value in the
  -- sequence is 'NoEvent'.
  (Event a
x) >>= :: forall a b. Event a -> (a -> Event b) -> Event b
>>= a -> Event b
k = a -> Event b
k a
x
  Event a
NoEvent  >>= a -> Event b
_  = forall a. Event a
NoEvent

  >> :: forall a b. Event a -> Event b -> Event b
(>>) = forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)

  -- | See 'pure'.
  return :: forall a. a -> Event a
return          = forall (f :: * -> *) a. Applicative f => a -> f a
pure

#if !(MIN_VERSION_base(4,13,0))
  -- | Fail with 'NoEvent'.
  fail            = Fail.fail
#endif

instance Fail.MonadFail Event where
  -- | Fail with 'NoEvent'.
  fail :: forall a. String -> Event a
fail String
_          = forall a. Event a
NoEvent

-- | Alternative instance
instance Alternative Event where
  -- | An empty alternative carries no event, so it is ignored.
  empty :: forall a. Event a
empty = forall a. Event a
NoEvent
  -- | Merge favouring the left event ('NoEvent' only if both are
  -- 'NoEvent').
  Event a
NoEvent <|> :: forall a. Event a -> Event a -> Event a
<|> Event a
r = Event a
r
  Event a
l       <|> Event a
_ = Event a
l

-- | NFData instance
instance NFData a => NFData (Event a) where
  -- | Evaluate value carried by event.
  rnf :: Event a -> ()
rnf Event a
NoEvent   = ()
  rnf (Event a
a) = forall a. NFData a => a -> ()
rnf a
a seq :: forall a b. a -> b -> b
`seq` ()

-- * Internal utilities for event construction

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

-- | Convert a maybe value into a event ('Event' is isomorphic to 'Maybe').
maybeToEvent :: Maybe a -> Event a
maybeToEvent :: forall a. Maybe a -> Event a
maybeToEvent Maybe a
Nothing  = forall a. Event a
NoEvent
maybeToEvent (Just a
a) = forall a. a -> Event a
Event a
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 :: forall a b. a -> (b -> a) -> Event b -> a
event a
a b -> a
_ Event b
NoEvent   = a
a
event a
_ b -> a
f (Event b
b) = b -> a
f b
b

-- | Extract the value from an event. Fails if there is no event.
fromEvent :: Event a -> a
fromEvent :: forall a. Event a -> a
fromEvent (Event a
a) = a
a
fromEvent Event a
NoEvent   = forall a. String -> String -> String -> a
usrErr String
"Yampa" String
"fromEvent" String
"Not an event."

-- | Tests whether the input represents an actual event.
isEvent :: Event a -> Bool
isEvent :: forall a. Event a -> Bool
isEvent Event a
NoEvent   = Bool
False
isEvent (Event a
_) = Bool
True

-- | Negation of 'isEvent'.
isNoEvent :: Event a -> Bool
isNoEvent :: forall a. Event a -> Bool
isNoEvent = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> Bool
isEvent

-- * Event tagging

-- | Tags an (occurring) event with a value ("replacing" the old value).
--
-- Applicative-based definition:
--  tag = ($>)
tag :: Event a -> b -> Event b
Event a
e tag :: forall a b. Event a -> b -> Event b
`tag` b
b = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const b
b) Event a
e

-- | Tags an (occurring) event with a value ("replacing" the old value). Same
-- as 'tag' with the arguments swapped.
--
-- Applicative-based definition:
-- tagWith = (<$)
tagWith :: b -> Event a -> Event b
tagWith :: forall a b. a -> Event b -> Event a
tagWith = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Event a -> b -> Event b
tag

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

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

-- | Left-biased event merge (always prefer left event, if present).
lMerge :: Event a -> Event a -> Event a
lMerge :: forall a. Event a -> Event a -> Event a
lMerge = forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

-- | Right-biased event merge (always prefer right event, if present).
rMerge :: Event a -> Event a -> Event a
rMerge :: forall a. Event a -> Event a -> Event a
rMerge = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

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

-- | Event merge parameterized by a conflict resolution function.
--
-- Applicative-based definition:
-- mergeBy f le re = (f <$> le <*> re) <|> le <|> re
mergeBy :: (a -> a -> a) -> Event a -> Event a -> Event a
mergeBy :: forall a. (a -> a -> a) -> Event a -> Event a -> Event a
mergeBy a -> a -> a
_       Event a
NoEvent      Event a
NoEvent      = forall a. Event a
NoEvent
mergeBy a -> a -> a
_       le :: Event a
le@(Event a
_) Event a
NoEvent      = Event a
le
mergeBy a -> a -> a
_       Event a
NoEvent      re :: Event a
re@(Event a
_) = Event a
re
mergeBy a -> a -> a
resolve (Event a
l)    (Event a
r)    = forall a. a -> Event a
Event (a -> a -> a
resolve a
l a
r)

-- | A generic event merge-map utility that maps event occurrences,
-- merging the results. The first three arguments are mapping functions,
-- the third of which will only be used when both events are present.
-- Therefore, 'mergeBy' = 'mapMerge' 'id' 'id'
--
-- Applicative-based definition:
-- mapMerge lf rf lrf le re = (f <$> le <*> re) <|> (lf <$> le) <|> (rf <$> re)
mapMerge :: (a -> c) -> (b -> c) -> (a -> b -> c)
            -> Event a -> Event b -> Event c
mapMerge :: forall a c b.
(a -> c)
-> (b -> c) -> (a -> b -> c) -> Event a -> Event b -> Event c
mapMerge a -> c
_  b -> c
_  a -> b -> c
_   Event a
NoEvent   Event b
NoEvent   = forall a. Event a
NoEvent
mapMerge a -> c
lf b -> c
_  a -> b -> c
_   (Event a
l) Event b
NoEvent   = forall a. a -> Event a
Event (a -> c
lf a
l)
mapMerge a -> c
_  b -> c
rf a -> b -> c
_   Event a
NoEvent   (Event b
r) = forall a. a -> Event a
Event (b -> c
rf b
r)
mapMerge a -> c
_  b -> c
_  a -> b -> c
lrf (Event a
l) (Event b
r) = forall a. a -> Event a
Event (a -> b -> c
lrf a
l b
r)

-- | Merge a list of events; foremost event has priority.
--
-- Foldable-based definition:
-- mergeEvents :: Foldable t => t (Event a) -> Event a
-- mergeEvents =  asum
mergeEvents :: [Event a] -> Event a
mergeEvents :: forall a. [Event a] -> Event a
mergeEvents = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Event a -> Event a -> Event a
lMerge forall a. Event a
NoEvent

-- | Collect simultaneous event occurrences; no event if none.
--
-- Traverable-based definition:
-- catEvents :: Foldable t => t (Event a) -> Event (t a)
-- catEvents e  = if (null e) then NoEvent else (sequenceA e)
catEvents :: [Event a] -> Event [a]
catEvents :: forall a. [Event a] -> Event [a]
catEvents [Event a]
eas = case [ a
a | Event a
a <- [Event a]
eas ] of
                  [] -> forall a. Event a
NoEvent
                  [a]
as -> forall a. a -> Event a
Event [a]
as

-- | Join (conjunction) of two events. Only produces an event
-- if both events exist.
--
-- Applicative-based definition:
-- joinE = liftA2 (,)
joinE :: Event a -> Event b -> Event (a,b)
joinE :: forall a b. Event a -> Event b -> Event (a, b)
joinE Event a
NoEvent   Event b
_         = forall a. Event a
NoEvent
joinE Event a
_         Event b
NoEvent   = forall a. Event a
NoEvent
joinE (Event a
l) (Event b
r) = forall a. a -> Event a
Event (a
l,b
r)

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

-- * Event filtering

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

-- | Combined event mapping and filtering. Note: since 'Event' is a 'Functor',
-- see 'fmap' for a simpler version of this function with no filtering.
mapFilterE :: (a -> Maybe b) -> Event a -> Event b
mapFilterE :: forall a b. (a -> Maybe b) -> Event a -> Event b
mapFilterE a -> Maybe b
f Event a
e = Event a
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. Maybe a -> Event a
maybeToEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
f)

-- | Enable/disable event occurrences based on an external condition.
gate :: Event a -> Bool -> Event a
Event a
_ gate :: forall a. Event a -> Bool -> Event a
`gate` Bool
False = forall a. Event a
NoEvent
Event a
e `gate` Bool
True  = Event a
e