{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Network.Testing.Data.Signal
  ( -- * Events
    Events
  , eventsFromList
  , eventsFromListUpToTime
  , eventsToList
  , selectEvents
    -- * Low level access
  , primitiveTransformEvents
  , TS (..)
  , E (..)
    -- * Signals
  , Signal
    -- ** Construction and conversion
  , fromChangeEvents
  , toChangeEvents
  , fromEvents
    -- ** QuickCheck
  , signalProperty
    -- * Simple signal transformations
  , truncateAt
  , stable
  , nub
  , nubBy
    -- * Temporal operations
  , linger
  , timeout
  , until
  , difference
  , scanl
    -- * Set-based temporal operations
  , keyedTimeout
  , keyedLinger
  , keyedUntil
  ) where

import           Prelude hiding (scanl, until)

import qualified Data.Foldable as Deque (toList)
import           Data.List (groupBy)
import           Data.Maybe (maybeToList)
import           Data.OrdPSQ (OrdPSQ)
import qualified Data.OrdPSQ as PSQ
import           Data.Set (Set)
import qualified Data.Set as Set
import           Deque.Lazy (Deque)
import qualified Deque.Lazy as Deque

import           Control.Monad.Class.MonadTime (DiffTime, Time (..), addTime)


import           Test.QuickCheck




--
-- Time stamps and events
--

-- The instance Applicative Signal relies on merging event streams.
-- The IO simulator's treatment of time means that we can have many
-- events that occur at the same virtual time, though they are stil
-- causually ordered.
--
-- We need these compound time stamps to be able to resolve the order
-- of the events that have the same Time when merging event streams.
-- The compound time stamp records the event number from the original
-- trace, for events derivied from the original trace. For artificially
-- constructed events, they can use small or big counters to be ordered
-- before or after other events at the same time. Negative counters are
-- permitted for this purpose.

data TS = TS !Time !Int
  deriving (TS -> TS -> Bool
(TS -> TS -> Bool) -> (TS -> TS -> Bool) -> Eq TS
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TS -> TS -> Bool
$c/= :: TS -> TS -> Bool
== :: TS -> TS -> Bool
$c== :: TS -> TS -> Bool
Eq, Eq TS
Eq TS
-> (TS -> TS -> Ordering)
-> (TS -> TS -> Bool)
-> (TS -> TS -> Bool)
-> (TS -> TS -> Bool)
-> (TS -> TS -> Bool)
-> (TS -> TS -> TS)
-> (TS -> TS -> TS)
-> Ord TS
TS -> TS -> Bool
TS -> TS -> Ordering
TS -> TS -> TS
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TS -> TS -> TS
$cmin :: TS -> TS -> TS
max :: TS -> TS -> TS
$cmax :: TS -> TS -> TS
>= :: TS -> TS -> Bool
$c>= :: TS -> TS -> Bool
> :: TS -> TS -> Bool
$c> :: TS -> TS -> Bool
<= :: TS -> TS -> Bool
$c<= :: TS -> TS -> Bool
< :: TS -> TS -> Bool
$c< :: TS -> TS -> Bool
compare :: TS -> TS -> Ordering
$ccompare :: TS -> TS -> Ordering
$cp1Ord :: Eq TS
Ord, Int -> TS -> ShowS
[TS] -> ShowS
TS -> String
(Int -> TS -> ShowS)
-> (TS -> String) -> ([TS] -> ShowS) -> Show TS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TS] -> ShowS
$cshowList :: [TS] -> ShowS
show :: TS -> String
$cshow :: TS -> String
showsPrec :: Int -> TS -> ShowS
$cshowsPrec :: Int -> TS -> ShowS
Show)

-- A single event or entry in a time series, annotated with its timestamp.
--
data E a = E {-# UNPACK #-} !TS a
  deriving (Int -> E a -> ShowS
[E a] -> ShowS
E a -> String
(Int -> E a -> ShowS)
-> (E a -> String) -> ([E a] -> ShowS) -> Show (E a)
forall a. Show a => Int -> E a -> ShowS
forall a. Show a => [E a] -> ShowS
forall a. Show a => E a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [E a] -> ShowS
$cshowList :: forall a. Show a => [E a] -> ShowS
show :: E a -> String
$cshow :: forall a. Show a => E a -> String
showsPrec :: Int -> E a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> E a -> ShowS
Show, a -> E b -> E a
(a -> b) -> E a -> E b
(forall a b. (a -> b) -> E a -> E b)
-> (forall a b. a -> E b -> E a) -> Functor E
forall a b. a -> E b -> E a
forall a b. (a -> b) -> E a -> E b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> E b -> E a
$c<$ :: forall a b. a -> E b -> E a
fmap :: (a -> b) -> E a -> E b
$cfmap :: forall a b. (a -> b) -> E a -> E b
Functor)


--
-- Events
--

-- | A time-ordered trace of discrete events that occur at specific times.
--
-- This corresponds for example to a trace of events or observations from a
-- simulation.
--
newtype Events a = Events [E a]
  deriving (Int -> Events a -> ShowS
[Events a] -> ShowS
Events a -> String
(Int -> Events a -> ShowS)
-> (Events a -> String) -> ([Events a] -> ShowS) -> Show (Events a)
forall a. Show a => Int -> Events a -> ShowS
forall a. Show a => [Events a] -> ShowS
forall a. Show a => Events a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Events a] -> ShowS
$cshowList :: forall a. Show a => [Events a] -> ShowS
show :: Events a -> String
$cshow :: forall a. Show a => Events a -> String
showsPrec :: Int -> Events a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Events a -> ShowS
Show, a -> Events b -> Events a
(a -> b) -> Events a -> Events b
(forall a b. (a -> b) -> Events a -> Events b)
-> (forall a b. a -> Events b -> Events a) -> Functor Events
forall a b. a -> Events b -> Events a
forall a b. (a -> b) -> Events a -> Events b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Events b -> Events a
$c<$ :: forall a b. a -> Events b -> Events a
fmap :: (a -> b) -> Events a -> Events b
$cfmap :: forall a b. (a -> b) -> Events a -> Events b
Functor)

-- | Construct 'Events' from a time series.
--
eventsFromList :: [(Time, a)] -> Events a
eventsFromList :: [(Time, a)] -> Events a
eventsFromList [(Time, a)]
txs =
    [E a] -> Events a
forall a. [E a] -> Events a
Events [ TS -> a -> E a
forall a. TS -> a -> E a
E (Time -> Int -> TS
TS Time
t Int
i) a
x
           | ((Time
t, a
x), Int
i) <- [(Time, a)] -> [Int] -> [((Time, a), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Time, a)]
txs [Int
100, Int
102..] ]


-- | Construct 'Events' from a time series.
--
-- The time series is truncated at (but not including) the given time. This is
-- necessary to check properties over finite prefixes of infinite time series.
--
eventsFromListUpToTime :: Time -> [(Time, a)] -> Events a
eventsFromListUpToTime :: Time -> [(Time, a)] -> Events a
eventsFromListUpToTime Time
horizon [(Time, a)]
txs =
    [E a] -> Events a
forall a. [E a] -> Events a
Events [ TS -> a -> E a
forall a. TS -> a -> E a
E (Time -> Int -> TS
TS Time
t Int
i) a
x
           | let txs' :: [(Time, a)]
txs' = ((Time, a) -> Bool) -> [(Time, a)] -> [(Time, a)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Time
t,a
_) -> Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
horizon) [(Time, a)]
txs
           , ((Time
t, a
x), Int
i) <- [(Time, a)] -> [Int] -> [((Time, a), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Time, a)]
txs' [Int
100, Int
102..] ]


eventsToList :: Events a -> [(Time, a)]
eventsToList :: Events a -> [(Time, a)]
eventsToList (Events [E a]
txs) = [ (Time
t, a
x) | E (TS Time
t Int
_i) a
x <- [E a]
txs ]

selectEvents :: (a -> Maybe b) -> Events a -> Events b
selectEvents :: (a -> Maybe b) -> Events a -> Events b
selectEvents a -> Maybe b
select (Events [E a]
txs) =
    [E b] -> Events b
forall a. [E a] -> Events a
Events [ TS -> b -> E b
forall a. TS -> a -> E a
E TS
t b
y | E TS
t a
x <- [E a]
txs, b
y <- Maybe b -> [b]
forall a. Maybe a -> [a]
maybeToList (a -> Maybe b
select a
x) ]

primitiveTransformEvents :: ([E a] -> [E b]) -> Events a -> Events b
primitiveTransformEvents :: ([E a] -> [E b]) -> Events a -> Events b
primitiveTransformEvents [E a] -> [E b]
f (Events [E a]
txs) = [E b] -> Events b
forall a. [E a] -> Events a
Events ([E a] -> [E b]
f [E a]
txs)


--
-- Signals
--

-- | A signal is a time-varying value. It has a value at all times. It changes
-- value at discrete times, i.e. it is not continuous.
--
data Signal a = Signal a [E a]
  deriving (Int -> Signal a -> ShowS
[Signal a] -> ShowS
Signal a -> String
(Int -> Signal a -> ShowS)
-> (Signal a -> String) -> ([Signal a] -> ShowS) -> Show (Signal a)
forall a. Show a => Int -> Signal a -> ShowS
forall a. Show a => [Signal a] -> ShowS
forall a. Show a => Signal a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Signal a] -> ShowS
$cshowList :: forall a. Show a => [Signal a] -> ShowS
show :: Signal a -> String
$cshow :: forall a. Show a => Signal a -> String
showsPrec :: Int -> Signal a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Signal a -> ShowS
Show, a -> Signal b -> Signal a
(a -> b) -> Signal a -> Signal b
(forall a b. (a -> b) -> Signal a -> Signal b)
-> (forall a b. a -> Signal b -> Signal a) -> Functor Signal
forall a b. a -> Signal b -> Signal a
forall a b. (a -> b) -> Signal a -> Signal b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Signal b -> Signal a
$c<$ :: forall a b. a -> Signal b -> Signal a
fmap :: (a -> b) -> Signal a -> Signal b
$cfmap :: forall a b. (a -> b) -> Signal a -> Signal b
Functor)

instance Applicative Signal where
    pure :: a -> Signal a
pure  a
x = a -> [E a] -> Signal a
forall a. a -> [E a] -> Signal a
Signal a
x []
    Signal (a -> b)
f <*> :: Signal (a -> b) -> Signal a -> Signal b
<*> Signal a
x = Signal (a -> b) -> Signal a -> Signal b
forall a b. Signal (a -> b) -> Signal a -> Signal b
mergeSignals Signal (a -> b)
f Signal a
x

mergeSignals :: Signal (a -> b) -> Signal a -> Signal b
mergeSignals :: Signal (a -> b) -> Signal a -> Signal b
mergeSignals (Signal a -> b
f0 [E (a -> b)]
fs0) (Signal a
x0 [E a]
xs0) =
    b -> [E b] -> Signal b
forall a. a -> [E a] -> Signal a
Signal (a -> b
f0 a
x0) ((a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
forall a b.
(a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
go a -> b
f0 a
x0 ((E (a -> b) -> E a -> Ordering)
-> [E (a -> b)] -> [E a] -> [MergeResult (E (a -> b)) (E a)]
forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy E (a -> b) -> E a -> Ordering
forall a b. E a -> E b -> Ordering
compareTimestamp [E (a -> b)]
fs0 [E a]
xs0))
  where
    go :: (a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
    go :: (a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
go a -> b
_ a
_ []                                  = []
    go a -> b
_ a
x (OnlyInLeft   (E TS
t a -> b
f)         : [MergeResult (E (a -> b)) (E a)]
rs) = TS -> b -> E b
forall a. TS -> a -> E a
E TS
t (a -> b
f a
x) E b -> [E b] -> [E b]
forall a. a -> [a] -> [a]
: (a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
forall a b.
(a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
go a -> b
f a
x [MergeResult (E (a -> b)) (E a)]
rs
    go a -> b
f a
_ (OnlyInRight          (E TS
t a
x) : [MergeResult (E (a -> b)) (E a)]
rs) = TS -> b -> E b
forall a. TS -> a -> E a
E TS
t (a -> b
f a
x) E b -> [E b] -> [E b]
forall a. a -> [a] -> [a]
: (a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
forall a b.
(a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
go a -> b
f a
x [MergeResult (E (a -> b)) (E a)]
rs
    go a -> b
_ a
_ (InBoth       (E TS
t a -> b
f) (E TS
_ a
x) : [MergeResult (E (a -> b)) (E a)]
rs) = TS -> b -> E b
forall a. TS -> a -> E a
E TS
t (a -> b
f a
x) E b -> [E b] -> [E b]
forall a. a -> [a] -> [a]
: (a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
forall a b.
(a -> b) -> a -> [MergeResult (E (a -> b)) (E a)] -> [E b]
go a -> b
f a
x [MergeResult (E (a -> b)) (E a)]
rs

compareTimestamp :: E a -> E b -> Ordering
compareTimestamp :: E a -> E b -> Ordering
compareTimestamp (E TS
ts a
_) (E TS
ts' b
_) = TS -> TS -> Ordering
forall a. Ord a => a -> a -> Ordering
compare TS
ts TS
ts'


-- | Construct a 'Signal' from an initial value and a time series of events
-- that represent new values of the signal.
--
-- This only makes sense for events that sample a single time-varying value.
--
fromChangeEvents :: a -> Events a -> Signal a
fromChangeEvents :: a -> Events a -> Signal a
fromChangeEvents a
x (Events [E a]
xs) = a -> [E a] -> Signal a
forall a. a -> [E a] -> Signal a
Signal a
x [E a]
xs


-- | Convert a 'Signal' into a time series of events when the signal value
-- changes.
--
toChangeEvents :: Signal a -> Events a
toChangeEvents :: Signal a -> Events a
toChangeEvents = [E a] -> Events a
forall a. [E a] -> Events a
Events ([E a] -> Events a) -> (Signal a -> [E a]) -> Signal a -> Events a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal a -> [E a]
forall a. Signal a -> [E a]
toTimeSeries

toTimeSeries :: Signal a -> [E a]
toTimeSeries :: Signal a -> [E a]
toTimeSeries (Signal a
x [E a]
xs) = TS -> a -> E a
forall a. TS -> a -> E a
E (Time -> Int -> TS
TS (DiffTime -> Time
Time DiffTime
0) Int
0) a
x E a -> [E a] -> [E a]
forall a. a -> [a] -> [a]
: [E a]
xs


-- | Construct a 'Signal' that represents a time series of discrete events. The
-- signal is @Just@ the event value at the time of the event, and is @Nothing@
-- at all other times.
--
-- Note that this signal \"instantaneously\" takes the event value and reverts
-- to @Nothing@ before time moves on. Therefore this kind of signal is not
-- \"stable\" in the sense of 'stableSignal'.
--
fromEvents :: Events a -> Signal (Maybe a)
fromEvents :: Events a -> Signal (Maybe a)
fromEvents (Events [E a]
txs) =
    Maybe a -> [E (Maybe a)] -> Signal (Maybe a)
forall a. a -> [E a] -> Signal a
Signal Maybe a
forall a. Maybe a
Nothing
           [ TS -> Maybe a -> E (Maybe a)
forall a. TS -> a -> E a
E (Time -> Int -> TS
TS Time
t Int
i') Maybe a
s
           | E (TS Time
t Int
i) a
x <- [E a]
txs
           , (Int
i', Maybe a
s) <- [(Int
i, a -> Maybe a
forall a. a -> Maybe a
Just a
x), (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Maybe a
forall a. Maybe a
Nothing)]
           ]


-- | A signal can change value more than once at a single point of time.
--
-- Sometimes we are interested only in the final \"stable\" value of the signal
-- before time moves on. This function discards the other values, keeping only
-- the final value at each time.
--
stable :: Signal a -> Signal a
stable :: Signal a -> Signal a
stable (Signal a
x [E a]
xs) =
    a -> [E a] -> Signal a
forall a. a -> [E a] -> Signal a
Signal a
x ((([E a] -> E a) -> [[E a]] -> [E a]
forall a b. (a -> b) -> [a] -> [b]
map [E a] -> E a
forall a. [a] -> a
last ([[E a]] -> [E a]) -> ([E a] -> [[E a]]) -> [E a] -> [E a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (E a -> E a -> Bool) -> [E a] -> [[E a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy E a -> E a -> Bool
forall a a. E a -> E a -> Bool
sameTime) [E a]
xs)
  where
    sameTime :: E a -> E a -> Bool
sameTime (E (TS Time
t Int
_) a
_) (E (TS Time
t' Int
_) a
_) = Time
t Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
t'

-- Truncate a 'Signal' after a given time. This is typically necessary to
-- check properties over finite prefixes of infinite signals.
--
truncateAt :: Time -> Signal a -> Signal a
truncateAt :: Time -> Signal a -> Signal a
truncateAt Time
horizon (Signal a
x [E a]
txs) =
    a -> [E a] -> Signal a
forall a. a -> [E a] -> Signal a
Signal a
x ((E a -> Bool) -> [E a] -> [E a]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(E (TS Time
t Int
_) a
_) -> Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
horizon) [E a]
txs)


-- | Sometimes the way a signal is constructed leads to duplicate signal values
-- which can slow down signal processing. This tidies up the signal by
-- eliminating the duplicates. This does not change the meaning (provided the
-- 'Eq' instance is true equality).
--
nub :: Eq a => Signal a -> Signal a
nub :: Signal a -> Signal a
nub = (a -> a -> Bool) -> Signal a -> Signal a
forall a. (a -> a -> Bool) -> Signal a -> Signal a
nubBy a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==)

nubBy :: (a -> a -> Bool) -> Signal a -> Signal a
nubBy :: (a -> a -> Bool) -> Signal a -> Signal a
nubBy a -> a -> Bool
eq (Signal a
x0 [E a]
xs0) =
    a -> [E a] -> Signal a
forall a. a -> [E a] -> Signal a
Signal a
x0 (a -> [E a] -> [E a]
go a
x0 [E a]
xs0)
  where
    go :: a -> [E a] -> [E a]
go a
_ [] = []
    go a
x (E TS
t a
x' : [E a]
xs)
      | a
x a -> a -> Bool
`eq` a
x' = a -> [E a] -> [E a]
go a
x [E a]
xs
      | Bool
otherwise = TS -> a -> E a
forall a. TS -> a -> E a
E TS
t a
x' E a -> [E a] -> [E a]
forall a. a -> [a] -> [a]
: a -> [E a] -> [E a]
go a
x' [E a]
xs


-- | A linger signal remains @True@ for the given time after the underlying
-- signal is @True@.
--
linger :: DiffTime
       -> (a -> Bool)
       -> Signal a
       -> Signal Bool
linger :: DiffTime -> (a -> Bool) -> Signal a -> Signal Bool
linger = String -> DiffTime -> (a -> Bool) -> Signal a -> Signal Bool
forall a. HasCallStack => String -> a
error String
"TODO: Signal.linger"


-- | Make a timeout signal, based on observing an underlying signal.
--
-- The timeout signal takes the value @True@ when the timeout has occurred, and
-- @False@ otherwise.
--
-- The timeout is controlled by an \"arming\" function on the underlying signal.
-- The arming function should return @True@ when the timeout should be started,
-- and it returns the time to wait before the timeout fires. The arming function
-- should return @False@ when the timeout should be cancelled or not started.
--
-- The output signal becomes @True@ when the arming function has been
-- continuously active (i.e. returning @True@) for the given duration.
--
timeout :: forall a.
           DiffTime    -- ^ timeout duration
        -> (a -> Bool) -- ^ the arming function
        -> Signal a
        -> Signal Bool
timeout :: DiffTime -> (a -> Bool) -> Signal a -> Signal Bool
timeout DiffTime
d a -> Bool
arm =
    Bool -> [E Bool] -> Signal Bool
forall a. a -> [E a] -> Signal a
Signal Bool
False
  ([E Bool] -> Signal Bool)
-> (Signal a -> [E Bool]) -> Signal a -> Signal Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [E a] -> [E Bool]
disarmed
  ([E a] -> [E Bool]) -> (Signal a -> [E a]) -> Signal a -> [E Bool]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal a -> [E a]
forall a. Signal a -> [E a]
toTimeSeries
  where
    disarmed :: [E a] -> [E Bool]
    disarmed :: [E a] -> [E Bool]
disarmed []          = []
    disarmed (E ts :: TS
ts@(TS Time
t Int
_) a
x : [E a]
txs)
      | a -> Bool
arm a
x     = Time -> [E a] -> [E Bool]
armed (DiffTime
d DiffTime -> Time -> Time
`addTime` Time
t) (TS -> a -> E a
forall a. TS -> a -> E a
E TS
ts a
x E a -> [E a] -> [E a]
forall a. a -> [a] -> [a]
: [E a]
txs)
      | Bool
otherwise = TS -> Bool -> E Bool
forall a. TS -> a -> E a
E TS
ts Bool
False E Bool -> [E Bool] -> [E Bool]
forall a. a -> [a] -> [a]
: [E a] -> [E Bool]
disarmed [E a]
txs

    armed :: Time -> [E a] -> [E Bool]
    armed :: Time -> [E a] -> [E Bool]
armed !Time
expiry [] = [TS -> Bool -> E Bool
forall a. TS -> a -> E a
E TS
expiryTS Bool
True] where expiryTS :: TS
expiryTS = Time -> Int -> TS
TS Time
expiry Int
0

    armed !Time
expiry (E ts :: TS
ts@(TS Time
t Int
_) a
x : [E a]
txs)
      | Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
expiry  = TS -> Bool -> E Bool
forall a. TS -> a -> E a
E TS
expiryTS Bool
True  E Bool -> [E Bool] -> [E Bool]
forall a. a -> [a] -> [a]
: [E a] -> [E Bool]
expired (TS -> a -> E a
forall a. TS -> a -> E a
E TS
ts a
x E a -> [E a] -> [E a]
forall a. a -> [a] -> [a]
: [E a]
txs)
      | Bool -> Bool
not (a -> Bool
arm a
x) = TS -> Bool -> E Bool
forall a. TS -> a -> E a
E TS
ts       Bool
False E Bool -> [E Bool] -> [E Bool]
forall a. a -> [a] -> [a]
: [E a] -> [E Bool]
disarmed [E a]
txs
      | Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
expiry  = TS -> Bool -> E Bool
forall a. TS -> a -> E a
E TS
ts       Bool
False E Bool -> [E Bool] -> [E Bool]
forall a. a -> [a] -> [a]
: Time -> [E a] -> [E Bool]
armed Time
expiry [E a]
txs
      | Bool
otherwise   = TS -> Bool -> E Bool
forall a. TS -> a -> E a
E TS
expiryTS Bool
True  E Bool -> [E Bool] -> [E Bool]
forall a. a -> [a] -> [a]
: [E a] -> [E Bool]
expired [E a]
txs
      where
        expiryTS :: TS
expiryTS = Time -> Int -> TS
TS Time
expiry Int
0

    expired :: [E a] -> [E Bool]
    expired :: [E a] -> [E Bool]
expired [] = []
    expired (E TS
t a
x : [E a]
txs)
      | a -> Bool
arm a
x      = TS -> Bool -> E Bool
forall a. TS -> a -> E a
E TS
t Bool
True  E Bool -> [E Bool] -> [E Bool]
forall a. a -> [a] -> [a]
: [E a] -> [E Bool]
expired  [E a]
txs
      | Bool
otherwise  = TS -> Bool -> E Bool
forall a. TS -> a -> E a
E TS
t Bool
False E Bool -> [E Bool] -> [E Bool]
forall a. a -> [a] -> [a]
: [E a] -> [E Bool]
disarmed [E a]
txs


until :: (a -> Bool) -- ^ Start
      -> (a -> Bool) -- ^ Stop
      -> Signal a
      -> Signal Bool
until :: (a -> Bool) -> (a -> Bool) -> Signal a -> Signal Bool
until a -> Bool
_ = String -> (a -> Bool) -> Signal a -> Signal Bool
forall a. HasCallStack => String -> a
error String
"TODO: Signal.until"


-- | Make a signal that keeps track of recent activity, based on observing an
-- underlying signal.
--
-- The underlying signal is scrutinised with the provided \"activity interest\"
-- function that tells us if the signal value is activity of interest to track.
-- If it is, the given key is entered into the result signal set for the given
-- time duration. If the same activity occurs again before the duration expires
-- then the expiry will be extended to the new deadline (it is not cumulative).
-- The key will be removed from the result signal set when it expires.
--
keyedLinger :: forall a b. Ord b
            => DiffTime
            -> (a -> Set b)  -- ^ The activity set signal
            -> Signal a
            -> Signal (Set b)
keyedLinger :: DiffTime -> (a -> Set b) -> Signal a -> Signal (Set b)
keyedLinger DiffTime
d a -> Set b
activity =
    Set b -> [E (Set b)] -> Signal (Set b)
forall a. a -> [E a] -> Signal a
Signal Set b
forall a. Set a
Set.empty
  ([E (Set b)] -> Signal (Set b))
-> (Signal a -> [E (Set b)]) -> Signal a -> Signal (Set b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set b -> OrdPSQ b Time () -> [E a] -> [E (Set b)]
go Set b
forall a. Set a
Set.empty OrdPSQ b Time ()
forall k p v. OrdPSQ k p v
PSQ.empty
  ([E a] -> [E (Set b)])
-> (Signal a -> [E a]) -> Signal a -> [E (Set b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal a -> [E a]
forall a. Signal a -> [E a]
toTimeSeries
  where
    go :: Set b
       -> OrdPSQ b Time ()
       -> [E a]
       -> [E (Set b)]
    go :: Set b -> OrdPSQ b Time () -> [E a] -> [E (Set b)]
go Set b
_ OrdPSQ b Time ()
_ [] = []

    go Set b
lingerSet OrdPSQ b Time ()
lingerPSQ (E ts :: TS
ts@(TS Time
t Int
_) a
xs : [E a]
txs)
      | Just (b
x, Time
t', ()
_, OrdPSQ b Time ()
lingerPSQ') <- OrdPSQ b Time () -> Maybe (b, Time, (), OrdPSQ b Time ())
forall k p v.
(Ord k, Ord p) =>
OrdPSQ k p v -> Maybe (k, p, v, OrdPSQ k p v)
PSQ.minView OrdPSQ b Time ()
lingerPSQ
      , Time
t' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
t
      , let lingerSet' :: Set b
lingerSet' = b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.delete b
x Set b
lingerSet
      = TS -> Set b -> E (Set b)
forall a. TS -> a -> E a
E (Time -> Int -> TS
TS Time
t' Int
0) Set b
lingerSet' E (Set b) -> [E (Set b)] -> [E (Set b)]
forall a. a -> [a] -> [a]
: Set b -> OrdPSQ b Time () -> [E a] -> [E (Set b)]
go Set b
lingerSet' OrdPSQ b Time ()
lingerPSQ' (TS -> a -> E a
forall a. TS -> a -> E a
E TS
ts a
xs E a -> [E a] -> [E a]
forall a. a -> [a] -> [a]
: [E a]
txs)

    go Set b
lingerSet OrdPSQ b Time ()
lingerPSQ (E ts :: TS
ts@(TS Time
t Int
_) a
x : [E a]
txs) =
      let ys :: Set b
ys         = a -> Set b
activity a
x
          lingerSet' :: Set b
lingerSet' = Set b
lingerSet Set b -> Set b -> Set b
forall a. Semigroup a => a -> a -> a
<> Set b
ys
          lingerPSQ' :: OrdPSQ b Time ()
lingerPSQ' = (OrdPSQ b Time () -> b -> OrdPSQ b Time ())
-> OrdPSQ b Time () -> Set b -> OrdPSQ b Time ()
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (\OrdPSQ b Time ()
s b
y -> b -> Time -> () -> OrdPSQ b Time () -> OrdPSQ b Time ()
forall k p v.
(Ord k, Ord p) =>
k -> p -> v -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.insert b
y Time
t' () OrdPSQ b Time ()
s) OrdPSQ b Time ()
lingerPSQ Set b
ys
          t' :: Time
t'         = DiffTime -> Time -> Time
addTime DiffTime
d Time
t
       in if Set b
lingerSet' Set b -> Set b -> Bool
forall a. Eq a => a -> a -> Bool
/= Set b
lingerSet
            then TS -> Set b -> E (Set b)
forall a. TS -> a -> E a
E TS
ts Set b
lingerSet' E (Set b) -> [E (Set b)] -> [E (Set b)]
forall a. a -> [a] -> [a]
: Set b -> OrdPSQ b Time () -> [E a] -> [E (Set b)]
go Set b
lingerSet' OrdPSQ b Time ()
lingerPSQ' [E a]
txs
            else                   Set b -> OrdPSQ b Time () -> [E a] -> [E (Set b)]
go Set b
lingerSet' OrdPSQ b Time ()
lingerPSQ' [E a]
txs


-- | Make a signal that says if a given event longed at least a certain time
-- (timeout), based on observing an underlying signal.
--
-- The underlying signal is scrutinised with the provided \"timeout arming\"
-- function that tells us if the signal value is interesting to track.
-- If it is, we arm it with a timeout and see, if until the timeout goes off
-- there's no other event to arm. If any activity occurs again before the
-- previous timeout, then the timeout is reset with the new event and the other
-- one is discarded.
--
keyedTimeout :: forall a b. Ord b
             => DiffTime
             -> (a -> Set b)  -- ^ The timeout arming set signal
             -> Signal a
             -> Signal (Set b)
keyedTimeout :: DiffTime -> (a -> Set b) -> Signal a -> Signal (Set b)
keyedTimeout DiffTime
d a -> Set b
arm =
    Set b -> [E (Set b)] -> Signal (Set b)
forall a. a -> [E a] -> Signal a
Signal Set b
forall a. Set a
Set.empty
  ([E (Set b)] -> Signal (Set b))
-> (Signal a -> [E (Set b)]) -> Signal a -> Signal (Set b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set b -> OrdPSQ b Time () -> Set b -> [E a] -> [E (Set b)]
go Set b
forall a. Set a
Set.empty OrdPSQ b Time ()
forall k p v. OrdPSQ k p v
PSQ.empty Set b
forall a. Set a
Set.empty
  ([E a] -> [E (Set b)])
-> (Signal a -> [E a]) -> Signal a -> [E (Set b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal a -> [E a]
forall a. Signal a -> [E a]
toTimeSeries
  where
    go :: Set b
       -> OrdPSQ b Time ()
       -> Set b
       -> [E a]
       -> [E (Set b)]
    go :: Set b -> OrdPSQ b Time () -> Set b -> [E a] -> [E (Set b)]
go Set b
_ OrdPSQ b Time ()
_ Set b
_ [] = []

    go Set b
armedSet OrdPSQ b Time ()
armedPSQ Set b
timedout (E ts :: TS
ts@(TS Time
t Int
_) a
x : [E a]
txs)
      | Just (b
y, Time
t', ()
_, OrdPSQ b Time ()
armedPSQ') <- OrdPSQ b Time () -> Maybe (b, Time, (), OrdPSQ b Time ())
forall k p v.
(Ord k, Ord p) =>
OrdPSQ k p v -> Maybe (k, p, v, OrdPSQ k p v)
PSQ.minView OrdPSQ b Time ()
armedPSQ
      , Time
t' Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
< Time
t
      , let armedSet' :: Set b
armedSet' = b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.delete b
y Set b
armedSet
            timedout' :: Set b
timedout' = b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.insert b
y Set b
timedout
      = TS -> Set b -> E (Set b)
forall a. TS -> a -> E a
E (Time -> Int -> TS
TS Time
t' Int
0) Set b
timedout' E (Set b) -> [E (Set b)] -> [E (Set b)]
forall a. a -> [a] -> [a]
: Set b -> OrdPSQ b Time () -> Set b -> [E a] -> [E (Set b)]
go Set b
armedSet' OrdPSQ b Time ()
armedPSQ' Set b
timedout' (TS -> a -> E a
forall a. TS -> a -> E a
E TS
ts a
x E a -> [E a] -> [E a]
forall a. a -> [a] -> [a]
: [E a]
txs)

    go Set b
armedSet OrdPSQ b Time ()
armedPSQ Set b
timedout (E ts :: TS
ts@(TS Time
t Int
_) a
x : [E a]
txs) =
      let armedSet' :: Set b
armedSet' = a -> Set b
arm a
x
          armedAdd :: Set b
armedAdd  = Set b
armedSet' Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set b
armedSet
          armedDel :: Set b
armedDel  = Set b
armedSet  Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set b
armedSet'
          armedPSQ' :: OrdPSQ b Time ()
armedPSQ' = (OrdPSQ b Time () -> Set b -> OrdPSQ b Time ())
-> Set b -> OrdPSQ b Time () -> OrdPSQ b Time ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((OrdPSQ b Time () -> b -> OrdPSQ b Time ())
-> OrdPSQ b Time () -> Set b -> OrdPSQ b Time ()
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (\OrdPSQ b Time ()
s b
y -> b -> Time -> () -> OrdPSQ b Time () -> OrdPSQ b Time ()
forall k p v.
(Ord k, Ord p) =>
k -> p -> v -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.insert b
y Time
t' () OrdPSQ b Time ()
s)) Set b
armedAdd
                    (OrdPSQ b Time () -> OrdPSQ b Time ())
-> (OrdPSQ b Time () -> OrdPSQ b Time ())
-> OrdPSQ b Time ()
-> OrdPSQ b Time ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OrdPSQ b Time () -> Set b -> OrdPSQ b Time ())
-> Set b -> OrdPSQ b Time () -> OrdPSQ b Time ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((OrdPSQ b Time () -> b -> OrdPSQ b Time ())
-> OrdPSQ b Time () -> Set b -> OrdPSQ b Time ()
forall a b. (a -> b -> a) -> a -> Set b -> a
Set.foldl' (\OrdPSQ b Time ()
s b
y -> b -> OrdPSQ b Time () -> OrdPSQ b Time ()
forall k p v. (Ord k, Ord p) => k -> OrdPSQ k p v -> OrdPSQ k p v
PSQ.delete b
y       OrdPSQ b Time ()
s)) Set b
armedDel
                    (OrdPSQ b Time () -> OrdPSQ b Time ())
-> OrdPSQ b Time () -> OrdPSQ b Time ()
forall a b. (a -> b) -> a -> b
$ OrdPSQ b Time ()
armedPSQ
          t' :: Time
t'        = DiffTime -> Time -> Time
addTime DiffTime
d Time
t
          timedout' :: Set b
timedout' = Set b
timedout Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set b
armedSet'
       in if Set b
timedout' Set b -> Set b -> Bool
forall a. Eq a => a -> a -> Bool
/= Set b
timedout
            then TS -> Set b -> E (Set b)
forall a. TS -> a -> E a
E TS
ts Set b
timedout' E (Set b) -> [E (Set b)] -> [E (Set b)]
forall a. a -> [a] -> [a]
: Set b -> OrdPSQ b Time () -> Set b -> [E a] -> [E (Set b)]
go Set b
armedSet' OrdPSQ b Time ()
armedPSQ' Set b
timedout' [E a]
txs
            else                  Set b -> OrdPSQ b Time () -> Set b -> [E a] -> [E (Set b)]
go Set b
armedSet' OrdPSQ b Time ()
armedPSQ' Set b
timedout' [E a]
txs


keyedUntil :: forall a b. Ord b
           => (a -> Set b)   -- ^ Start set signal
           -> (a -> Set b)   -- ^ Stop set signal
           -> (a -> Bool)    -- ^ Stop all signal
           -> Signal a
           -> Signal (Set b)
keyedUntil :: (a -> Set b)
-> (a -> Set b) -> (a -> Bool) -> Signal a -> Signal (Set b)
keyedUntil a -> Set b
start a -> Set b
stop a -> Bool
stopAll =
    Set b -> [E (Set b)] -> Signal (Set b)
forall a. a -> [E a] -> Signal a
Signal Set b
forall a. Set a
Set.empty
  ([E (Set b)] -> Signal (Set b))
-> (Signal a -> [E (Set b)]) -> Signal a -> Signal (Set b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set b -> [E a] -> [E (Set b)]
go Set b
forall a. Set a
Set.empty
  ([E a] -> [E (Set b)])
-> (Signal a -> [E a]) -> Signal a -> [E (Set b)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal a -> [E a]
forall a. Signal a -> [E a]
toTimeSeries
  where

    go :: Set b
       -> [E a]
       -> [E (Set b)]
    go :: Set b -> [E a] -> [E (Set b)]
go Set b
_ [] = []
    go Set b
active (E TS
t a
x : [E a]
txs)
       | Set b
active' Set b -> Set b -> Bool
forall a. Eq a => a -> a -> Bool
/= Set b
active = TS -> Set b -> E (Set b)
forall a. TS -> a -> E a
E TS
t Set b
active' E (Set b) -> [E (Set b)] -> [E (Set b)]
forall a. a -> [a] -> [a]
: Set b -> [E a] -> [E (Set b)]
go Set b
active' [E a]
txs
       | Bool
otherwise         =               Set b -> [E a] -> [E (Set b)]
go Set b
active' [E a]
txs
      where
        active' :: Set b
active'
          | a -> Bool
stopAll a
x = Set b
forall a. Set a
Set.empty
          | Bool
otherwise = (Set b
active Set b -> Set b -> Set b
forall a. Semigroup a => a -> a -> a
<> a -> Set b
start a
x) Set b -> Set b -> Set b
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ a -> Set b
stop a
x


difference :: (a -> a -> b)
           -> Signal a
           -> Signal (Maybe b)
difference :: (a -> a -> b) -> Signal a -> Signal (Maybe b)
difference a -> a -> b
diff (Signal a
x0 [E a]
txs0) =
    Maybe b -> [E (Maybe b)] -> Signal (Maybe b)
forall a. a -> [E a] -> Signal a
Signal Maybe b
forall a. Maybe a
Nothing (a -> [E a] -> [E (Maybe b)]
go a
x0 [E a]
txs0)
  where
    go :: a -> [E a] -> [E (Maybe b)]
go a
_ []                    = []
    go a
x (E (TS Time
t Int
i) a
x' : [E a]
txs) = TS -> Maybe b -> E (Maybe b)
forall a. TS -> a -> E a
E (Time -> Int -> TS
TS Time
t Int
i)    (b -> Maybe b
forall a. a -> Maybe a
Just (a -> a -> b
diff a
x a
x'))
                               E (Maybe b) -> [E (Maybe b)] -> [E (Maybe b)]
forall a. a -> [a] -> [a]
: TS -> Maybe b -> E (Maybe b)
forall a. TS -> a -> E a
E (Time -> Int -> TS
TS Time
t (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) Maybe b
forall a. Maybe a
Nothing
                               E (Maybe b) -> [E (Maybe b)] -> [E (Maybe b)]
forall a. a -> [a] -> [a]
: a -> [E a] -> [E (Maybe b)]
go a
x' [E a]
txs


scanl :: (b -> a -> b) -> b -> Signal a -> Signal b
scanl :: (b -> a -> b) -> b -> Signal a -> Signal b
scanl b -> a -> b
f b
z (Signal a
x0 [E a]
txs0) =
    let a0 :: b
a0 = b -> a -> b
f b
z a
x0 in
    b -> [E b] -> Signal b
forall a. a -> [E a] -> Signal a
Signal b
a0 (b -> [E a] -> [E b]
go b
a0 [E a]
txs0)
  where
    go :: b -> [E a] -> [E b]
go !b
_ []             = []
    go !b
a (E TS
ts a
x : [E a]
txs) = TS -> b -> E b
forall a. TS -> a -> E a
E TS
ts b
a' E b -> [E b] -> [E b]
forall a. a -> [a] -> [a]
: b -> [E a] -> [E b]
go b
a' [E a]
txs
                          where
                            a' :: b
a' = b -> a -> b
f b
a a
x

--
-- QuickCheck
--

-- | Check a property over a 'Signal'. The property should be true at all times.
--
-- On failure it shows the @n@ most recent signal values.
--
signalProperty :: forall a. Int -> (a -> String)
               -> (a -> Bool) -> Signal a -> Property
signalProperty :: Int -> (a -> String) -> (a -> Bool) -> Signal a -> Property
signalProperty Int
atMost a -> String
showSignalValue a -> Bool
p =
    Int -> Deque (Time, a) -> [(Time, a)] -> Property
go Int
0 Deque (Time, a)
forall a. Monoid a => a
mempty ([(Time, a)] -> Property)
-> (Signal a -> [(Time, a)]) -> Signal a -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Events a -> [(Time, a)]
forall a. Events a -> [(Time, a)]
eventsToList (Events a -> [(Time, a)])
-> (Signal a -> Events a) -> Signal a -> [(Time, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal a -> Events a
forall a. Signal a -> Events a
toChangeEvents
  where
    go :: Int -> Deque (Time, a) -> [(Time, a)] -> Property
    go :: Int -> Deque (Time, a) -> [(Time, a)] -> Property
go !Int
_ !Deque (Time, a)
_ []                   = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    go !Int
n !Deque (Time, a)
recent ((Time
t, a
x) : [(Time, a)]
txs) | a -> Bool
p a
x = Property
next
      where
        next :: Property
next
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
atMost = Int -> Deque (Time, a) -> [(Time, a)] -> Property
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (              (Time, a) -> Deque (Time, a) -> Deque (Time, a)
forall a. a -> Deque a -> Deque a
Deque.snoc (Time
t,a
x)  Deque (Time, a)
recent) [(Time, a)]
txs
          | Bool
otherwise  = Int -> Deque (Time, a) -> [(Time, a)] -> Property
go Int
n     ((Deque (Time, a) -> Deque (Time, a)
forall a. Deque a -> Deque a
Deque.tail (Deque (Time, a) -> Deque (Time, a))
-> (Deque (Time, a) -> Deque (Time, a))
-> Deque (Time, a)
-> Deque (Time, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, a) -> Deque (Time, a) -> Deque (Time, a)
forall a. a -> Deque a -> Deque a
Deque.snoc (Time
t,a
x)) Deque (Time, a)
recent) [(Time, a)]
txs

    go !Int
_ !Deque (Time, a)
recent ((Time
t, a
x) : [(Time, a)]
_) = String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
details (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False)
      where
        details :: String
details =
          [String] -> String
unlines [ String
"Last " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
atMost String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" signal values:"
                  , [String] -> String
unlines [ Time -> String
forall a. Show a => a -> String
show Time
t' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\t: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
showSignalValue a
x'
                            | (Time
t',a
x') <- Deque (Time, a) -> [(Time, a)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Deque.toList Deque (Time, a)
recent ]
                  , String
"Property violated at: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Time -> String
forall a. Show a => a -> String
show Time
t
                  , String
"Invalid signal value:"
                  , a -> String
showSignalValue a
x
                  ]

--
-- Utils
--

-- | Generic merging utility. For sorted input lists this is a full outer join.
--
mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy a -> b -> Ordering
cmp = [a] -> [b] -> [MergeResult a b]
merge
  where
    merge :: [a] -> [b] -> [MergeResult a b]
merge []     [b]
ys     = [ b -> MergeResult a b
forall a b. b -> MergeResult a b
OnlyInRight b
y | b
y <- [b]
ys]
    merge [a]
xs     []     = [ a -> MergeResult a b
forall a b. a -> MergeResult a b
OnlyInLeft  a
x | a
x <- [a]
xs]
    merge (a
x:[a]
xs) (b
y:[b]
ys) =
      case a
x a -> b -> Ordering
`cmp` b
y of
        Ordering
GT -> b -> MergeResult a b
forall a b. b -> MergeResult a b
OnlyInRight   b
y MergeResult a b -> [MergeResult a b] -> [MergeResult a b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [MergeResult a b]
merge (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) [b]
ys
        Ordering
EQ -> a -> b -> MergeResult a b
forall a b. a -> b -> MergeResult a b
InBoth      a
x b
y MergeResult a b -> [MergeResult a b] -> [MergeResult a b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [MergeResult a b]
merge [a]
xs     [b]
ys
        Ordering
LT -> a -> MergeResult a b
forall a b. a -> MergeResult a b
OnlyInLeft  a
x   MergeResult a b -> [MergeResult a b] -> [MergeResult a b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [MergeResult a b]
merge [a]
xs  (b
yb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
ys)

data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b
  deriving (MergeResult a b -> MergeResult a b -> Bool
(MergeResult a b -> MergeResult a b -> Bool)
-> (MergeResult a b -> MergeResult a b -> Bool)
-> Eq (MergeResult a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b.
(Eq a, Eq b) =>
MergeResult a b -> MergeResult a b -> Bool
/= :: MergeResult a b -> MergeResult a b -> Bool
$c/= :: forall a b.
(Eq a, Eq b) =>
MergeResult a b -> MergeResult a b -> Bool
== :: MergeResult a b -> MergeResult a b -> Bool
$c== :: forall a b.
(Eq a, Eq b) =>
MergeResult a b -> MergeResult a b -> Bool
Eq, Int -> MergeResult a b -> ShowS
[MergeResult a b] -> ShowS
MergeResult a b -> String
(Int -> MergeResult a b -> ShowS)
-> (MergeResult a b -> String)
-> ([MergeResult a b] -> ShowS)
-> Show (MergeResult a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> MergeResult a b -> ShowS
forall a b. (Show a, Show b) => [MergeResult a b] -> ShowS
forall a b. (Show a, Show b) => MergeResult a b -> String
showList :: [MergeResult a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [MergeResult a b] -> ShowS
show :: MergeResult a b -> String
$cshow :: forall a b. (Show a, Show b) => MergeResult a b -> String
showsPrec :: Int -> MergeResult a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> MergeResult a b -> ShowS
Show)