{-# LANGUAGE TypeOperators, ScopedTypeVariables
           , FlexibleInstances, MultiParamTypeClasses
           , GeneralizedNewtypeDeriving
 #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}

-- For ghc-6.6 compatibility
-- {-# OPTIONS_GHC -fglasgow-exts -Wall #-}

----------------------------------------------------------------------
-- |
-- Module      :  FRP.Reactive.PrimReactive
-- Copyright   :  (c) Conal Elliott 2007
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Functional /events/ and /reactive values/.  Semantically, an 'Event' is
-- stream of future values in time order.  A 'Reactive' value is a
-- discretly time-varying value.
-- 
-- Many of the operations on events and reactive values are packaged as
-- instances of the standard type classes 'Monoid', 'Functor',
-- 'Applicative', and 'Monad'.
-- 
-- This module focuses on representation and primitives defined in terms
-- of the representation.  See also "FRP.Reactive.Reactive", which
-- re-exports this module, plus extras that do not exploit the
-- representation.  My intention for this separation is to ease
-- experimentation with alternative representations.
-- 
-- Although the basic 'Reactive' type describes /discretely/-changing
-- values, /continuously/-changing values can be modeled simply as
-- reactive functions.  See "FRP.Reactive.Behavior" for a convenient type
-- composition of 'Reactive' and a constant-optimized representation of
-- functions of time.  The exact packaging of discrete vs continuous will
-- probably change with more experience.
----------------------------------------------------------------------

module FRP.Reactive.PrimReactive
  ( -- * Events and reactive values
    EventG, ReactiveG
    -- * Operations on events and reactive values
  , stepper, switcher, withTimeGE, withTimeGR
  , futuresE, listEG, atTimesG, atTimeG
  , snapshotWith, accumE, accumR, once
  , firstRestE, firstE, restE
  , remainderR, withRestE, untilE
  -- , traceE, traceR
  -- , mkEvent, mkEventTrace, mkEventShow
  , eventOcc
    -- * To be moved elsewhere
  , joinMaybes, filterMP
  -- * To be removed when it gets used somewhere
  , isMonotoneR
  -- * Testing
  , batch, infE
  ) where

import Data.Monoid
import Control.Applicative
import Control.Monad
import Data.Function (on)

-- TODO: eliminate the needs for this stuff.
import Control.Concurrent (threadDelay)
import Control.Exception (evaluate)
import System.IO.Unsafe

import Test.QuickCheck hiding (evaluate)
import Test.QuickCheck.Instances
import Test.QuickCheck.Checkers
import Test.QuickCheck.Classes
-- import Data.List

-- TypeCompose
import Control.Compose ((:.)(..), inO2, Monoid_f(..))
import Data.Pair
import Control.Instances () -- Monoid (IO ())

import Data.Unamb (race)

import Data.Max
import Data.AddBounds
import FRP.Reactive.Future hiding (batch)
import FRP.Reactive.Internal.Reactive

{--------------------------------------------------------------------
    Events and reactive values
--------------------------------------------------------------------}

-- Bogus EqProp instance.  TODO: replace with a random equality test, such
-- that the collection of all generated tests covers equality.

instance (Eq a, Eq b, EqProp a, EqProp b) => EqProp (EventG a b) where
  a =-= b = foldr (.&.) (property True) $ zipWith (=-=) (f a) (f b)
    where
      f = take 20 . eFutures

arbitraryE :: (Num t, Ord t, Arbitrary t, Arbitrary u) => Gen (EventG t u)
arbitraryE = frequency 
  [ (1, liftA2 ((liftA. liftA) futuresE addStart) arbitrary futureList)
  , (4, liftA futuresE futureList)
  ]
  where
    earliestFuture = Future . (,) (Max MinBound)
    addStart = (:).earliestFuture
    futureList = frequency [(10, futureListFinite), (1,futureListInf)]
    futureListFinite = liftA2 (zipWith future) nondecreasing arbitrary
    futureListInf =
      liftA2 (zipWith future) (resize 10 nondecreasingInf)
                              (infiniteList arbitrary)

instance (Arbitrary t, Ord t, Num t, Arbitrary a) => Arbitrary (EventG t a) where
  arbitrary   = arbitraryE
  -- TODO: Fix this coarbitrary instance  -- David
  coarbitrary = error "coarbitrary Events not supported"
  -- coarbitrary = coarbitrary . eFuture

----

-- Arbitrary works just like pairs:
instance (Arbitrary t, Arbitrary a, Num t, Ord t) => Arbitrary (ReactiveG t a) where
  arbitrary = liftA2 Stepper arbitrary arbitrary
  coarbitrary (a `Stepper` e) = coarbitrary e . coarbitrary a

instance Ord t => Model (ReactiveG t a) (t -> a) where
  model = rat

instance (Ord t, Arbitrary t, Show t, EqProp a) => EqProp (ReactiveG t a)
 where
   (=-=) = (=-=) `on` model

-- Initial value of a 'Reactive'
rInit :: ReactiveG t a -> a
rInit (a `Stepper` _) = a


{--------------------------------------------------------------------
    Instances
--------------------------------------------------------------------}

instance Ord t => Monoid (EventG t a) where
  mempty  = Event mempty
  mappend = inEvent2 merge

-- Standard instance for Applicative of Monoid
instance (Ord t, Monoid a) => Monoid (ReactiveG t a) where
  mempty  = pure mempty
  mappend = liftA2 mappend

-- | Merge two 'Future' streams into one.
merge :: Ord t => Binop (FutureG t (ReactiveG t a))
-- The following two lines seem to be too strict and are causing
-- reactive to lock up.  I.e. the time argument of one of these
-- must have been _|_, so when we pattern match against it, we 
-- block.
Future (Max MaxBound,_) `merge` v = v
u `merge` Future (Max MaxBound,_) = u
u `merge` v = 
  (inFutR (`merge` v) <$> u) `mappend` (inFutR (u `merge`) <$> v)

-- What's going on in this 'merge' definition?  Try two different
-- future paths.  If u arrives before v (or simultaneously), then
-- begin as u begins and then merge v with the rest of u.  Otherwise,
-- begin as v begins and then merge u with the rest of v.  Because of
-- the left-bias, make sure u fragments are always the first argument
-- to merge and v fragments are always the second.


-- Define functor instances in terms of each other.
instance Functor (EventG t) where
  fmap f = inEvent $ (fmap.fmap) f

instance Functor (ReactiveG t) where
  fmap f (a `Stepper` e) = f a `stepper` fmap f e

-- standard instance
instance Ord t => Applicative (EventG t) where
  pure = return
  _ <*> (Event (Future (Max MaxBound,_))) = mempty
  x <*> y = x `ap` y

-- standard instance
instance Ord t => Alternative (EventG t) where
  { empty = mempty; (<|>) = mappend }

instance Ord t => Pair (ReactiveG t) where
  -- pair :: ReactiveG t a -> ReactiveG t b -> ReactiveG t (a,b)
  (c `Stepper` ce) `pair` (d `Stepper` de) =
    (c,d) `accumR` pairEdit (ce,de)

instance Ord t => Applicative (ReactiveG t) where
  pure a = a `stepper` mempty
  -- Standard definition.  See 'Pair'.
  rf <*> rx = uncurry ($) <$> (rf `pair` rx)

-- A wonderful thing about the <*> definition for ReactiveG is that it
-- automatically caches the previous value of the function or argument
-- when the argument or function changes.


instance Ord t => Monad (EventG t) where
  return a = Event (pure (pure a))
  e >>= f  = joinE (fmap f e)

-- happy a t b. Same as (a `mappend` b) except takes advantage of knowledge
-- that t is a lower bound for the occurences of b. This allows for extra
-- laziness.
happy :: (Ord t) => EventG t a ->
                    Time t ->
                    EventG t a ->
                    EventG t a
happy a (Max MaxBound) _ = a
happy (Event (Future (Max MaxBound, _))) _ b = b
happy a@(Event (Future (t0, e `Stepper` ee'))) t b 
  | t0 <= t = (Event (Future (t0, e `Stepper` (happy ee' t b))))
  | otherwise = a `mappend` b


-- Note, joinE should not be called with an infinite list of events that all
-- occur at the same time.  It can't decide which occurs first.
joinE :: (Ord t) => EventG t (EventG t a) -> EventG t a
joinE (Event (Future (Max MaxBound, _))) = mempty
joinE (Event (Future (t0h, e `Stepper` ((Event (Future (Max MaxBound, _)))))))
  = adjustE t0h e
joinE (Event (Future (t0h, e `Stepper` ee'@((Event (Future (t1h, _)))))))
  = happy (adjustE t0h e) t1h (adjustTopE t0h (joinE ee'))

-- Original Version:
-- joinE (Event (Future (t0h, e `Stepper` ee'))) =
--   adjustE t0h e `mappend` adjustTopE t0h (joinE ee')

adjustTopE :: Ord t => Time t -> EventG t t1 -> EventG t t1
adjustTopE t0h (Event (Future (tah, r))) =
  Event (Future (t0h `max` tah,r))

adjustE :: Ord t => Time t -> EventG t t1 -> EventG t t1
adjustE _ e@(Event (Future (Max MaxBound, _))) = e

adjustE t0h (Event (Future (tah, a `Stepper` e))) =
  Event (Future (t1h,a `Stepper` adjustE t1h e))
  where
    t1h = t0h `max` tah

-- TODO: add adjustE explanation.  What's going on and why t1 in the
-- recursive call?  David's comment:
-- If we have an event [t1, t2] we know t2 >= t1 so (max t t2) == (max (max t t1) t2).
-- See http://hpaste.org/11518 for a def that doesn't change the lower bound.
-- 
-- What I remember is that this function is quite subtle w.r.t laziness.
-- There are some notes in the paper.  If i find instead that a simpler
-- definition is possible, so much the better.

-- Here's an alternative to joinE that is less strict, and doesn't cause
-- reactive to lock up.  Need to verify correctness.  (Does lock up with
-- the mappend optimization that eliminates a space/time leak.)
{-
joinE :: Ord t => EventG t (EventG t a) -> EventG t a
joinE (Event (Future (t0h, ~(e `Stepper` ee')))) =
   adjustE t0h (e `mappend` joinE ee')

adjustE t0h (Event (Future (tah, ~(a `Stepper` e)))) =
  Event (Future (t1h,a `Stepper` adjustE t1h e))
  where
    t1h = t0h `max` tah
-}

instance Ord t => MonadPlus (EventG t) where { mzero = mempty; mplus = mappend }

-- Standard instance for Applicative w/ join
instance Ord t => Monad (ReactiveG t) where
  return  = pure
  r >>= f = joinR (f <$> r)


{--------------------------------------------------------------------
    Operations on events and reactive values
--------------------------------------------------------------------}

-- | Reactive value from an initial value and a new-value event.
stepper :: a -> EventG t a -> ReactiveG t a
stepper = Stepper

-- -- | Turn a reactive value into an event, with the initial value
-- -- occurring at -Infinity.
-- --
-- -- Oops: breaks the semantic abstraction of 'Reactive' as a step
-- function.
-- rToE :: Ord t => ReactiveG t a -> EventG t a
-- rToE (a `Stepper` e) = pure a `mappend` e

-- | Switch between reactive values.
switcher :: Ord t => ReactiveG t a -> EventG t (ReactiveG t a) -> ReactiveG t a
r `switcher` e = join (r `stepper` e)

-- | Reactive 'join' (equivalent to 'join' but slightly more efficient, I think)
joinR :: Ord t => ReactiveG t (ReactiveG t a) -> ReactiveG t a

joinR ((a `Stepper` Event ur) `Stepper` e'@(Event urr)) = a `stepper` Event u
 where
   u = ((`switcher` e') <$> ur) `mappend` (join <$> urr)

-- The following simpler definition is wrong.  It keeps listening to @e@
-- even after @er@ has occurred.
-- joinR ((a `Stepper` e) `Stepper` er) = 
--   a `stepper` (e `mappend` join (rToE <$> er))

-- e  :: EventG t a
-- er :: EventG t (ReactiveG t a)
-- 
-- rToE <$> er ::: EventG t (EventG t a)
-- join (rToE <$> er) ::: EventG t a

-- | Access occurrence times in an event.  See also 'withTimeGR'.
withTimeGE :: EventG t a -> EventG t (a, Time t)
withTimeGE = inEvent $ inFuture $ \ (t,r) -> (t, withTimeGR t r)

-- | Access occurrence times in a reactive value.  See also 'withTimeGE'.
withTimeGR :: Time t -> ReactiveG t a -> ReactiveG t (a, Time t)
withTimeGR t (a `Stepper` e) = (a,t) `Stepper` withTimeGE e

-- | Convert a temporally monotonic list of futures to an event.  See also
-- the specialization 'listE'
listEG :: Ord t => [(t,a)] -> EventG t a
listEG = futuresE . map (uncurry future)

-- | Convert a temporally monotonic list of futures to an event
futuresE :: Ord t => [FutureG t a] -> EventG t a
futuresE [] = mempty
futuresE (Future (t,a) : futs) =
  -- trace ("l2E: "++show t) $
  Event (Future (t, a `stepper` futuresE futs))

-- TODO: redefine 'futuresE' as a fold
-- futuresE = foldr (\ fut e -> Event ((`stepper` e) <$> fut)) mempty

-- TODO: hide futuresE.  currently exported for use in TVal.  If I move to
-- Internal/Reactive, I have to move the monoid instance there, which
-- requires moving others as well.

-- | Event at given times.  See also 'atTimeG'.
atTimesG :: Ord t => [t] -> EventG t ()
atTimesG = listEG . fmap (flip (,) ())

-- | Single-occurrence event at given time.
atTimeG :: Ord t => t -> EventG t ()
atTimeG t = futuresE (pure (future t ()))

-- This variant of 'snapshot' has 'Nothing's where @b@ changed and @a@
-- didn't.
snap :: forall a b t. Ord t =>
        EventG t a -> ReactiveG t b -> EventG t (Maybe a, b)
ea `snap` (b0 `Stepper` eb) =
  (Nothing, b0) `accumE` (fmap fa ea `mappend` fmap fb eb)
 where
   fa :: a -> Unop (Maybe a, b)
   fb :: b -> Unop (Maybe a, b)
   fa a (_,b) = (Just a , b)
   fb b _     = (Nothing, b)

-- | Snapshot a reactive value whenever an event occurs and apply a
-- combining function to the event and reactive's values.
snapshotWith :: Ord t => (a -> b -> c) -> EventG t a -> ReactiveG t b -> EventG t c
snapshotWith f e r = joinMaybes $ fmap h (e `snap` r)
 where
   h (Nothing,_) = Nothing
   h (Just a ,b) = Just (f a b)

-- | Accumulating event, starting from an initial value and a
-- update-function event.  See also 'accumR'.
-- Example: (using a list rempresentation for events, for clarity
--   @10 `accumE`
--      [(5 seconds, (+2)),(10 seconds, (subtract 30)),(20 seconds,(*10))]
--     = [(5 seconds, 12),(10 seconds, -18),(20 seconds, -180)]@
-- If you want an initial occurance at @-infinity@ you can use @pure a
-- `mappend` accumE a e@
accumE :: a -> EventG t (a -> a) -> EventG t a
accumE a = inEvent $ fmap $ \ (f `Stepper` e') -> f a `accumR` e'

-- | Reactive value from an initial value and an updater event.  See also
-- 'accumE'.
accumR :: a -> EventG t (a -> a) -> ReactiveG t a
a `accumR` e = a `stepper` (a `accumE` e)

-- | Just the first occurrence of an event.
once :: Ord t => EventG t a -> EventG t a
once = inEvent $ fmap $ pure . rInit

-- | Decompose an event into its first occurrence value and a remainder
-- event.  See also 'firstE' and 'restE'.
firstRestE :: Ord t => EventG t a -> (a, EventG t a)
firstRestE (Event fut) = f (futVal fut)
  where
    f (a `Stepper` b) = (a,b)

-- | Extract the first occurrence value of an event.  See also
-- 'firstRestE' and 'restE'.
firstE :: Ord t => EventG t a -> a
firstE = fst . firstRestE

-- | Extract the remainder an event, after its first occurrence.  See also
-- 'firstRestE' and 'firstE'.
restE :: Ord t => EventG t a -> EventG t a
restE = snd . firstRestE


-- | Remaining part of an event.  See also 'withRestE'.
remainderR :: Ord t => EventG t a -> ReactiveG t (EventG t a)
remainderR e = e `stepper` (snd <$> withRestE e)

-- -- | Event remainders.  Replace event values with a reactive that starts
-- -- with that value and follows the event.  Sort of like 'tails'.
-- eventR :: Ord t => EventG t a -> EventG t (ReactiveG t a)
-- eventR = inEvent $ fmap $ \ r@(_ `Stepper` e') -> r `Stepper` eventR e'

-- Also try the following definition of remainderR

-- remainderR :: forall t a. Ord t => EventG t a -> ReactiveG t (EventG t a)
-- remainderR e = e `accumR` (next <$ e)
--  where
--    next :: Unop (EventG t a)
--    next ~(Event (Future (_, _ `Stepper` e'))) = e'

-- newtype EventG t a = Event { eFuture :: FutureG t (ReactiveG t a) }

-- | Access the remainder with each event occurrence.
withRestE :: EventG t a -> EventG t (a, EventG t a)
withRestE = inEvent $ fmap $
	    \ (a `Stepper` e') -> (a,e') `stepper` withRestE e'


-- | Truncate first event at first occurrence of second event.
untilE :: Ord t => EventG t a -> EventG t b -> EventG t a
ea `untilE` Event (Future ~(tb,_)) = ea `untilET` tb

-- | Truncate first event at the given time.
untilET :: Ord t => EventG t a -> Time t -> EventG t a

-- Event (Future (ta, ~(a `Stepper` e'))) `untilET` t = 
--   if ta < t then
--     Event (Future (ta, a `Stepper` (e' `untilET` t)))
--   else
--     mempty

-- Hm.  I doubt that the definition above gives sufficient temporal
-- laziness.  No information can come out of the result until the value of
-- @ta < t@ is determined, which is usually at about time @ta `min` t@.

-- So, try the following definition instead.  It immediately provides
-- lower bounds of both @ta@ and @t@ as lower bounds of the constructed
-- event occurrences.

Event (Future ~(ta, a `Stepper` e')) `untilET` t = 
  Event (Future (ta', a `Stepper` (e' `untilET` t)))
 where
   ta' = (ta `min` t) `max` (if ta < t then ta else maxBound)

-- I'm not sure about @<@ vs @<=@ above.

{-
-- | Tracing of events.
traceE :: Show t => (a -> String) -> EventG t a -> EventG t a

-- traceE shw = fmap (\ (t,a) -> trace (shw' t a) a) . withTimeGE
--  where
--    shw' t a = "time "++show t++": "++shw a

-- traceE shw = fmap (\ (t,a) -> trace (shw' t) a) . withTimeGE
--  where
--    shw' t = "time "++show t++"\n"

-- traceE shw = fmap (\ a -> trace (shw a) a)

-- Something is wonky.  Try this version, avoiding withTimeGE

traceE shw ~(Event (Future (t,r))) =
  Event (Future (trace ("time "++show t) t, traceR shw r))

-- | Tracing of reactive values
traceR :: Show t => (a -> String) -> Unop (ReactiveG t a)
traceR shw ~(a `Stepper` e) = trace ("val: "++shw a) $
                              a `Stepper` traceE shw e
-}

-- I'm experimenting with lazy patterns here.  They didn't help.
-- When time tracing is on, mappends don't work.  I think the problem is
-- that show extracts *all* information from a time, while 'min' and
-- '(<=)' don't.  Of course: consider two future occurrences being
-- compared.  Before any outer info can be extracted, the trace will
-- evaluate the whole time of a occurrence that hasn't happened yet.
-- 
-- To trace an event then, I really want to put partial traces into the
-- times, which will have to work specially for the time type.  Or I could
-- make a Traceable class.

{-

-- | Make an event and a sink for feeding the event.  Each value sent to
-- the sink becomes an occurrence of the event.
mkEvent :: Ord t => IO (EventG t a, SinkG t a)
mkEvent = do (fut,handler) <- newFuture
             -- remember how to save the next occurrence.
             r <- newIORef handler
             return (Event fut, writeTo r)
 where
   -- Fill in an occurrence while preparing for the next one
   writeTo r fut = do handler  <- readIORef r
                      (fut',handler') <- newFuture
                      writeIORef r handler'
                      handler $ fmap (`stepper` Event fut') fut

-- TODO: replace IORefs by mvars.  When I tried before, GuiTV input hung.

-- | Tracing variant of 'mkEvent'
mkEventTrace :: (Ord t, Show t) =>
                (a -> String) -> IO (EventG t a, SinkG t a)
mkEventTrace shw = second tr <$> mkEvent
 where
   tr handler = (putStrLn.shw') `mappend` handler
   shw' (Future (t,a)) = "Occurrence at time "++show t++": "++shw a

-- | Show specialization of 'mkEventTrace'
mkEventShow :: (Ord t, Show t, Show a) => String -> IO (EventG t a, SinkG t a)
mkEventShow str = mkEventTrace ((str ++).(' ':).show)

-}

-- | Get a future representing the first occurrence of the event together
-- with the event of all occurrences after that one.
eventOcc :: (Ord t) => EventG t a -> FutureG t (a, EventG t a)
eventOcc (Event fut)  = (\ (Stepper a e) -> (a,e)) <$> fut


-- | Sample a reactive value at a sequence of monotonically non-decreasing
-- times.  Deprecated, because it does not reveal when value is known to
-- be repeated in the output.  Those values won't be recomputed, but they
-- may be re-displayed.
rats :: Ord t => ReactiveG t a -> [t] -> [a] -- increasing times

_ `rats` [] = []

r@(a `Stepper` Event (Future (tr',r'))) `rats` ts@(t:ts')
  | ftime t <= tr' = a : r `rats` ts'
  | otherwise      = r' `rats` ts

-- Just for testing
rat :: Ord t => ReactiveG t a -> t -> a
rat r = head . rats r . (:[])


{--------------------------------------------------------------------
    Other instances
--------------------------------------------------------------------}

-- Standard instances
instance (Monoid_f f, Ord t) => Monoid_f (ReactiveG t :. f) where
    { mempty_f = O (pure mempty_f); mappend_f = inO2 (liftA2 mappend_f) }
instance (Ord t, Pair f) => Pair (ReactiveG t :. f) where pair = apPair

instance Unpair (ReactiveG t) where {pfst = fmap fst; psnd = fmap snd}

-- Standard instances
instance Ord t => Monoid_f (EventG t) where
  { mempty_f = mempty ; mappend_f = mappend }
instance Ord t => Monoid ((EventG t :. f) a) where
  { mempty = O mempty; mappend = inO2 mappend }
instance Ord t => Monoid_f (EventG t :. f) where
  { mempty_f = mempty ; mappend_f = mappend }
instance (Ord t, Copair f) => Pair (EventG t :. f) where
  pair = copair

-- Standard instance for functors
instance Unpair (EventG t) where {pfst = fmap fst; psnd = fmap snd}


{--------------------------------------------------------------------
    To be moved elsewhere
--------------------------------------------------------------------}

-- | Pass through @Just@ occurrences.
joinMaybes :: MonadPlus m => m (Maybe a) -> m a
joinMaybes = (>>= maybe mzero return)

-- | Pass through values satisfying @p@.
filterMP :: MonadPlus m => (a -> Bool) -> m a -> m a
filterMP p m = joinMaybes (liftM f m)
 where
   f a | p a        = Just a
       | otherwise  = Nothing

-- Alternatively:
-- filterMP p m = m >>= guarded p
--  where
--    guarded p x = guard (p x) >> return x

{--------------------------------------------------------------------
    Tests
--------------------------------------------------------------------}

-- TODO: Define more types like ApTy, use in batch below.  Move to checkers.
type ApTy f a b = f (a -> b) -> f a -> f b

batch :: TestBatch
batch = ( "Reactive.PrimReactive"
        , concatMap unbatch
          [ ("monotonicity",
              [ monotonicity2 "<*>"           
                 ((<*>) :: ApTy (EventG NumT) T T)
--                 ::    EventG NumT (T -> T)
--                    -> EventG NumT T
--                    -> EventG NumT T
              , monotonicity2 "adjustE"       (adjustE
                ::    Time NumT
                   -> EventG NumT NumT
                   -> EventG NumT NumT)
              , monotonicity  "join"          (join
                ::    EventG NumT (EventG NumT T)
                   -> EventG NumT T)
              , monotonicity  "withTimeGE"    (withTimeGE
                ::    EventG NumT T
                   -> EventG NumT (T, Time NumT))
              , monotonicity  "once"          (once
                ::    EventG NumT T
                   -> EventG NumT T)
              , monotonicity2 "accumE"        (accumE
                ::    T
                   -> EventG NumT (T -> T)
                   -> EventG NumT T)
              , monotonicity2 "mappend"       (mappend
                ::    EventG NumT T
                   -> EventG NumT T
                   -> EventG NumT T)
              , monotonicity2 "mplus"         (mplus
                ::    EventG NumT T
                   -> EventG NumT T
                   -> EventG NumT T)
              , monotonicity2 "<|>"           ((<|>)
                ::    EventG NumT T
                   -> EventG NumT T
                   -> EventG NumT T)
              , monotonicity2 "fmap"          (fmap
                ::    (T -> T)
                   -> EventG NumT T
                   -> EventG NumT T)
--              ,monotonicity2 "flip (>>=)"    (flip (>>=))
--              ,monotonicity2 (flip snapshot) "flip snapshot"
              ])
          , ("order preservation",
              [ simulEventOrder  "once"       (once
                ::    EventG NumT NumT
                   -> EventG NumT NumT)
              ])
          -- monad associativity fails
          -- , monad  (undefined :: EventG NumT (NumT,T,NumT))
          , monad  (undefined :: ReactiveG NumT (NumT,T,NumT))
          , monoid (undefined :: EventG NumT T)
          , monoid (undefined :: ReactiveG NumT [T])
--           , ("occurance count",
--              [("joinE", joinEOccuranceCount)]
--             )
          ]
        )

-- joinEOccuranceCount :: Property
-- joinEOccuranceCount =
--   forAll (finiteEvent $ finiteEvent arbitrary
--            :: Gen (EventG NumT (EventG NumT T)))
--          ((==) <$> (sum . map (length . toListE_) . toListE_)
--                <*> (length . toListE_ . joinE))

{-
toListE :: EventG t a -> [FutureG t a]
toListE (Event (Future (Max MaxBound, _             ))) = []
toListE (Event (Future (t0          , v `Stepper` e'))) = Future (t0,v) : toListE e'

toListE_ :: EventG t a -> [a]
toListE_ = map futVal . toListE
-}

monotonicity :: (Show a, Arbitrary a, Arbitrary t
                ,Num t, Ord t, Ord t')
             => String -> (EventG t a -> EventG t' a')
             -> (String,Property)
monotonicity n f = (n, property $ monotoneTest f)

monotonicity2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t
                 ,Num t, Ord t, Ord t')
              => String -> (b -> EventG t a -> EventG t' a')
              -> (String,Property)
monotonicity2 n f = (n, property $ monotoneTest2 f)

monotoneTest :: (Ord t') => (EventG t a -> EventG t' a')
                         -> EventG t a
                         -> Bool
monotoneTest f e = unsafePerformIO (       (evaluate (isMonotoneE . f $ e))
                                    `race` slowTrue)

monotoneTest2 :: (Show a, Show b, Arbitrary a, Arbitrary b, Arbitrary t
                 ,Num t, Ord t, Ord t')
              => (b -> EventG t a -> EventG t' a')
              -> (b ,  EventG t a) -> Bool
monotoneTest2 f (x,e) =
  unsafePerformIO (       (evaluate (isMonotoneE (x `f` e)))
                   `race` slowTrue)

slowTrue :: IO Bool
slowTrue = do threadDelay 10
              return True

-- TODO: Replace this stuff with a use of delay from Data.Later in checkers.


isMonotoneE :: (Ord t) => EventG t a -> Bool
isMonotoneE = liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
                          ((uncurry isMonotoneR') . unFuture . eFuture)

isMonotoneE' :: (Ord t) => (Time t) -> EventG t a -> Bool
isMonotoneE' t =
  liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
              ((\(t',r) -> t <= t' && isMonotoneR' t' r) . unFuture . eFuture)

isMonotoneR :: (Ord t) => ReactiveG t a -> Bool
isMonotoneR (_ `Stepper` e) = isMonotoneE e

isMonotoneR' :: (Ord t) => (Time t) -> ReactiveG t a -> Bool
isMonotoneR' t (_ `Stepper` e) = isMonotoneE' t e

simulEventOrder :: (Arbitrary t, Num t, Ord t
                   ,Arbitrary t', Num t', Ord t'
                   ,Num t'', Ord t'', Num t''', Ord t''')
                => String -> (EventG t t' -> EventG t'' t''')
                -> (String, Property)
simulEventOrder n f =
  (n,forAll genEvent (isStillOrderedE . f))
  where
    genEvent :: (Arbitrary t1, Num t1, Ord t1, Arbitrary t2, Num t2, Ord t2)
             => Gen (EventG t1 t2)
    genEvent = liftA futuresE (liftA2 (zipWith future) nondecreasing
                                                          increasing)
    isStillOrderedE :: (Num t1, Ord t1, Num t2, Ord t2) => EventG t1 t2 -> Bool
    isStillOrderedE =
      liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
                  (isStillOrderedR . futVal . eFuture)
    
    isStillOrderedR (a `Stepper` e) =
      isStillOrderedE' a e
    
    isStillOrderedE' a =
      liftA2 (||) ((==(Max MaxBound)) . futTime . eFuture)
                  (isStillOrderedR' a . futVal . eFuture)
    
    isStillOrderedR' a (b `Stepper` e) =
      a < b && isStillOrderedE' b e

-- An event to test with that is infinite
infE :: EventG NumT NumT
infE = futuresE (zipWith future [1..] [1..])