A short FRP implementation in Haskell (with comments)

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE RankNTypes #-}
{-|
Description: FRP interface definition and utility functions.
-}
module Frp.Class where

import Control.Monad.Fix
import Data.Kind (Type)
import Data.These
import Data.Semigroup (Semigroup(..),First(..))
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map as Map
import Data.Map (Map)
import Witherable
import Prelude hiding (filter)
import Data.These.Combinators (justThis)
import Data.Align (Semialign(..))

class (MonadFix (Behavior t), MonadFix (Moment t)) => Frp (t :: Type) where
  data Behavior t :: Type -> Type
  data Event t :: Type -> Type
  type Moment t :: Type -> Type
  mapMaybeMoment :: (a -> Moment t (Maybe b)) -> Event t a -> Event t b
  coincidence :: Event t (Event t a) -> Event t a
  merge :: Event t a -> Event t b -> Event t (These a b)
  never :: Event t a
  switch :: Behavior t (Event t a) -> Event t a
  now :: Moment t (Event t ())
  sample :: Behavior t a -> Moment t a
  hold :: a -> Event t a -> Moment t (Behavior t a)

mapMoment :: Frp t => (a -> Moment t b) -> Event t a -> Event t b
mapMoment f = mapMaybeMoment (fmap Just . f)

instance Frp t => Functor (Event t) where
  fmap f = mapMaybeMoment (pure . Just . f)

headE :: (Frp t) => Event t a -> Moment t (Event t a)
headE e = mfix $ fmap switch . hold e . fmap (const never)

instance (Frp t, Semigroup a) => Semigroup (Event t a) where
  a <> b = these id id (<>) <$> merge a b

instance (Frp t, Semigroup a) => Monoid (Event t a) where
  mempty = never

(<@>) :: Frp t => Behavior t (a -> b) -> Event t a -> Event t b
(<@>) b = mapMoment $ \x -> do
  f <- sample b
  pure . f $ x
infixl 4 <@>

(<@?>) :: Frp t => Behavior t (a -> Maybe b) -> Event t a -> Event t b
(<@?>) b = mapMaybeMoment $ \x -> do
  f <- sample b
  pure . f $ x
infixl 4 <@?>

(<@) :: (Frp t) => Behavior t b -> Event t a -> Event t b
(<@) = tag
infixl 4 <@

tag :: Frp t => Behavior t b -> Event t a -> Event t b
tag b = mapMoment $ \_ -> sample b

accum :: (Frp t) => (a -> b -> a) -> a -> Event t b -> Moment t (Behavior t a)
accum f a e = mfix $ \x -> hold a . mapMoment (\b -> (`f` b) <$> sample x) $ e

accumE :: (Frp t) => (a -> b -> a) -> a -> Event t b -> Moment t (Event t a)
accumE f a e = mdo
  let e' = mapMoment (\q -> (`f` q) <$> sample b) e
  b <- hold a e'
  pure e'

count :: (Frp t, Num n, Enum n) => Event t a -> Moment t (Behavior t n)
count = accum (\a _ -> succ a) 0

attachWith :: Frp t => (a1 -> a2 -> b) -> Behavior t a1 -> Event t a2 -> Event t b
attachWith f b e = f <$> b <@> e

leftmost :: Frp t => [Event t a] -> Event t a
leftmost = maybe never (fmap getFirst . sconcat . fmap (fmap First)) . nonEmpty

mergeMap :: (Frp t, Ord k) => Map k (Event t a) -> Event t (Map k a)
mergeMap = mconcat . fmap (\(t,e) -> Map.singleton t <$> e) . Map.toList

switchHoldPromptly :: (Frp t) => Event t a -> Event t (Event t a) -> Moment t (Event t a)
switchHoldPromptly ea0 eea = do
  bea <- hold ea0 eea
  let eLag = switch bea
      eCoincidences = coincidence eea
  return $ leftmost [eCoincidences, eLag]

instance Frp t => Filterable (Event t) where
  mapMaybe f = mapMaybeMoment (pure . f)

difference :: Frp t => Event t b1 -> Event t b2 -> Event t b1
difference a b = mapMaybe justThis $ merge a b


instance Frp t => Semialign (Event t) where
  align = merge

{-# LANGUAGE TypeFamilies #-}
{-|
Description: A pure (non-IO) implementation of the Frp interface.

In this pure implementation of 'Frp.Class.Frp', events, Behaviors, and Moment are implemented as
functions of time.  The implementation avoids referencing time whenever possible to make it clear
which functions depend only on some "current time" or the past as well.
-}
module Frp.Pure where

import Frp.Class
import Data.Kind (Type)
import Control.Monad.Fix
import Control.Monad
import Data.Align (align)
import Control.Monad.Trans.Maybe
import Data.Maybe ( fromMaybe )

data Pure (t :: Type)

instance (Ord t, Enum t) => Frp (Pure t) where
  newtype Behavior (Pure t) a = BehaviorP { at :: t -> a }
    deriving (Functor,Applicative,Monad,MonadFix)
  newtype Event (Pure t) a = EventP { occurs :: t -> Maybe a }
  type Moment (Pure t) = (->) t
  mapMaybeMoment f = EventP . runMaybeT . (MaybeT . f <=< MaybeT . occurs)
  coincidence = mapMaybeMoment occurs
  merge a b = EventP $ align <$> occurs a <*> occurs b
  never = EventP $ pure Nothing
  switch = EventP . (occurs <=< sample)
  now = fmap (EventP . fmap guard) (==)
  sample = at
  hold a e from = BehaviorP $ \t ->
    if t <= from
    then a
    else fromMaybe (sample (hold a e from) (pred t)) $ occurs e (pred t)

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-|
Description: An implementation of FRP via graph traversal.

The implementation performs a number of actions for every "frame".  A frame is a single logical
point in time at which any events might be occurring (including none occurring).  The full driving
algorithm can be seen in the 'runFrame' function.

First, a graph traversal algorithm visits every event to compute whether it occurs or not.  This
occurrence value is of a 'Maybe' type, where 'Nothing' signifies no occurrence.  The actual
traversal is embedded in the implementation of the combinators rather than having this concern
separated out.

While traversing, IO actions are enqueued to take care of caching occurrences and unsubscribing
(with 'postTraversalQueueRef'), as well as taking care of behavior initialization and updates (via
the 'behaviorInitsRef' and 'behaviorAssignmentsRef' queues).

After graph traversal, the various queues are processed and emptied.
-}
module Frp.Impl
(newEvent, subscribeEvent, runFrame, Impl, EventTrigger, ReadTime, readBehavior)
where

import Prelude hiding (filter)
import Frp.Class
import Control.Monad.Fix
import Control.Monad
import Data.IORef
import Data.Align (Semialign(..))
import Data.These
import Data.Maybe (fromMaybe, isJust)
import System.IO.Unsafe ( unsafePerformIO, unsafeInterleaveIO )
import qualified Data.IntMap as IntMap
import Control.Monad.Reader (ReaderT(..))
import GHC.IO (evaluate)
import Witherable
import Data.Foldable (for_)

data Impl

type Propagator a = Maybe a -> IO ()
type Unsubscriber = IO ()
type Invalidator = IO ()

-- | The root event 'rootTickE' has an occurrence whenever any event might have one.
{-# NOINLINE rootTickE #-}
rootTickE :: Event Impl ()
-- | The 'propagateRoot' action causes the root event to propagate with a unit-valued occurrence.
{-# NOINLINE propagateRoot #-}
propagateRoot :: IO ()
(rootTickE, propagateRoot) = unsafePerformIO $ do
  (eCached, doPropagate) <- managedSubscribersEvent
  pure (eCached, doPropagate (Just ()))

-- |
instance Frp Impl where
  -- Events are subscribed to with a callback ('Propagator'), called whenever the event has a known
  -- (non)-occurrence. Subscribing to an event returns an unsubscribe action. Unsubscribing stops
  -- callbacks from happening. This unsubscribing might be immediate or only happen when
  -- 'postTraversalQueueRef' is processed.
  newtype Event Impl a = EventI { subscribe :: Propagator a -> IO Unsubscriber }
  -- Behaviors are sampling functions which are passed an optional invalidator. This invalidator
  -- is run when the Behavior's value might change (but it could also stay the same).
  newtype Behavior Impl a = BehaviorI (ReaderT (Maybe Invalidator) IO a)
    deriving (Functor, Applicative, Monad, MonadFix)

  type Moment Impl = IO

  -- Never is implemented by filtering out all occurences from the root event.
  never :: Event Impl a
  never = undefined <$ filter (const False) rootTickE

  mapMaybeMoment :: (a -> Moment Impl (Maybe b)) -> Event Impl a -> Event Impl b
  mapMaybeMoment f e = cacheEvent $ EventI $ \propagate ->
    subscribe e $ propagate <=< fmap join . mapM f

  -- When the outer event is known to not have an occurrence, propagate non-occurrence. Otherwise,
  -- subscribe to the inner occurrence and queue-up its unsubscribe action.  It's possible to write
  -- the implementation so that unsubscribing happens immediately but using the queue made things
  -- more succinct.
  coincidence :: Event Impl (Event Impl a) -> Event Impl a
  coincidence e = cacheEvent $ EventI $ \propagate ->
    subscribe e $ maybe (propagate Nothing) (addToEnvQueue postTraversalQueueRef <=< (`subscribe` propagate))

  -- Subscribes to both merge inputs and cache the occurrences. When both (non-)occurrences are
  -- known, propagate and clear the caches. Unsubscribing unsubscribes from both input events.
  merge :: forall a b. Event Impl a -> Event Impl b -> Event Impl (These a b)
  merge a b = cacheEvent $ EventI $ \propagate -> do
    aOccRef <- newIORef Nothing
    bOccRef <- newIORef Nothing
    let doSub :: forall c. IORef (Maybe (Maybe c)) -> Event Impl c -> IO Unsubscriber
        doSub occRef e = subscribe e $ \occ -> do
            writeIORef occRef . Just $ occ
            -- Check if we have both inputs when any input is called. If yes, clear caches and
            -- propagate.
            mapM_ (\occRes -> do
                      writeIORef aOccRef Nothing
                      writeIORef bOccRef Nothing
                      propagate occRes)
              =<< liftA2 align <$> readIORef aOccRef <*> readIORef bOccRef
    (>>) <$> doSub aOccRef a <*> doSub bOccRef b

  -- Switch keeps the unsubscriber to the inner event in an 'IORef (Maybe Unsubscriber)'. As long as
  -- the result event of switch is subscribed to, the IORef is kept as Just Unsubscriber. On
  -- unsubscribing it's set to Nothing. When switchParent's invalidator runs, the old inner event is
  -- unsubscribed from and the IORef set to the new one. The invalidator only runs if the IORef is
  -- Just-valued still, so that unsubscribing from the resulting switch event stops new
  -- subscriptions (and semantics-breaking propagations) from happening.
  switch :: Behavior Impl (Event Impl a) -> Event Impl a
  switch (BehaviorI switchParent) = cacheEvent $ EventI $ \propagate -> mdo
    let unsubscribeAndSetUnsubscriberWith :: IO (Maybe (IO ())) -> IO ()
        unsubscribeAndSetUnsubscriberWith f = do
          maybeUnsubscribeInner <- readIORef maybeUnsubscribeInnerERef
          for_ maybeUnsubscribeInner $ \unsubscribe -> do
            unsubscribe
            writeIORef maybeUnsubscribeInnerERef =<< f
    maybeUnsubscribeInnerERef :: IORef (Maybe Unsubscriber) <-
      newIORef <=< fix $ \subscribeAndResetOnInvalidate ->
        fmap Just . (`subscribe` propagate) <=< runReaderT switchParent . Just
        $ unsubscribeAndSetUnsubscriberWith subscribeAndResetOnInvalidate
    pure $ unsubscribeAndSetUnsubscriberWith (pure Nothing)

  -- Hold returns a behavior which is initialized at behavior init time and changes at behavior
  -- assignment time. Whenever the behavior is sampled an invalidator action can be added which is
  -- called when the behavior changes. This is used to implement 'switch'.
  hold :: a -> Event Impl a -> Moment Impl (Behavior Impl a)
  hold v0 e = do
    invsRef <- newIORef [] -- The list of invalidators that have to run whenever the result behavior
                           -- changes.
    valRef <- newIORef v0
    -- Make sure not to touch 'e' eagerly, instead wait for Behavior init time.
    addToEnvQueue behaviorInitsRef $ void $ subscribe e $
      mapM_ (\a -> addToEnvQueue behaviorAssignmentsRef $ BehaviorAssignment valRef a invsRef)
    pure $ BehaviorI $ ReaderT $ \invalidator -> do
      mapM_ (modifyIORef invsRef . (:)) invalidator
      readIORef valRef

  now :: Moment Impl (Event Impl ())
  now = headE rootTickE

  -- Sample takes extra care to be lazy by delaying the evaluation of the sampled behavior.  The
  -- last moment by which the sample would need to be forced is the behavior's invalidation time,
  -- but here I've forced the evaluation at the next behavior init time.
  sample :: Behavior Impl a -> Moment Impl a
  sample (BehaviorI b) = do
    res <- unsafeInterleaveIO $ runReaderT b Nothing
    addToEnvQueue behaviorInitsRef $ void . evaluate $ res
    pure res

-- | An update to a behavior's cached value.
data BehaviorAssignment where
  BehaviorAssignment :: IORef a -> a -> IORef [Invalidator] -> BehaviorAssignment


-- | Returns a cached event which can have multiple subscribers and a propagating/cache update
-- procedure. The propagator is not allowed to be called outside of a frame (this is unenforced)!
managedSubscribersEvent :: IO (Event Impl a, Maybe a -> IO ())
managedSubscribersEvent = do
  subscribersRef <- newIORef mempty
  ctrRef <- newIORef 0
  occRef <- newIORef Nothing
  pure
    ( EventI $ \propagate -> do
        thisSubId <- atomicModifyIORef ctrRef (\i -> (succ i, i))
        modifyIORef subscribersRef $ IntMap.insert thisSubId propagate
        -- If occRef is already Just we have to propagate on subscribe
        -- because the subscription on e has already propagated:
        mapM_ propagate =<< readIORef occRef
        pure $ do
          old <- readIORef subscribersRef
          unless (IntMap.member thisSubId old) $ error "managedSubscribers unsubscribed twice"
          modifyIORef subscribersRef (IntMap.delete thisSubId)
    , \occ -> do
        writeAndScheduleClear occRef occ
        mapM_ ($ occ) =<< readIORef subscribersRef
    )

-- | Cache event occurrences.
cacheEvent :: forall a. Event Impl a -> Event Impl a
cacheEvent e = unsafePerformIO $ do
  (eCached, doPropagate) <- managedSubscribersEvent
  void . subscribe e $ doPropagate
  pure eCached

-- | For use in 'runFrame'.
newtype EventTrigger = EventTrigger { runEventTrigger :: IO () }

-- | Create a new event. Returns a "make trigger" function to which you can pass an occurrence value
-- and obtain an 'EventTrigger' for use with 'runFrame', and the new event.
newEvent :: IO (a -> EventTrigger, Event Impl a)
newEvent = do
  occRef <- newIORef Nothing -- Root event (non-)occurrence is always "known", thus Maybe a
  pure ( EventTrigger . writeAndScheduleClear occRef
       , mapMaybeMoment (const (readIORef occRef)) rootTickE
       )

-- | Subscribe to an event to obtain a "read occurrence" action which will contain the event
-- occurrence value when read inside the 'program' argument of 'runFrame'.
subscribeEvent :: forall a. Event Impl a -> IO (ReadTime (Maybe a))
subscribeEvent e = do
  occRef :: IORef (Maybe (Maybe a)) <- newIORef Nothing
  _ <- subscribe e $ writeAndScheduleClear occRef
  pure $ ReadTime $ fromMaybe (error "Occurrence read outside of runFrame?") <$> readIORef occRef

-- | For use in obtaining Event and Behavior values in 'runFrame'.
newtype ReadTime a = ReadTime { runReadTime :: IO a }
  deriving (Functor,Applicative,Monad)

-- | Return the current value of the behavior at "read time". If you want to read the next value of
-- a behavior you'll have to run 'runFrame' again, which can be done without triggering any events.
readBehavior :: Behavior Impl a -> ReadTime a
readBehavior (BehaviorI b) = ReadTime $ runReaderT b Nothing

-- | Inside the second argument you can read behaviors with 'readBehavior' and event occurrences
-- (after subscribing to an event with 'subscribeEvent').
runFrame :: [EventTrigger] -> ReadTime a -> IO a
runFrame triggers program = do
  let (Env { postTraversalQueueRef, behaviorInitsRef, behaviorAssignmentsRef }) = theEnv
  mapM_ runEventTrigger triggers
  propagateRoot
  res <- runReadTime program
  -- Lazily initialize behaviors here. Behavior initialization can queue up other behavior
  -- initialization if an untouched behavior is sampled.
  fix $ \runHoldInits -> do
    inits <- readIORef behaviorInitsRef
    unless (null inits) $ do
      writeIORef behaviorInitsRef []
      sequence_ inits
      runHoldInits
  -- Clear event occurrence caches and unsubscribe from events.
  atomicModifyIORef postTraversalQueueRef ([],) >>= sequence_
  -- Perform the updates of the behaviors' cached values.
  atomicModifyIORef behaviorAssignmentsRef ([],)
    >>= mapM_ (\(BehaviorAssignment valRef a invalidatorsRef) -> do
                  writeIORef valRef a
                  atomicModifyIORef invalidatorsRef ([],) >>= sequence_)
  flip unless (error "queues were not empty after runFrame")
    . and =<< sequence [ null <$> readIORef behaviorInitsRef
                       , null <$> readIORef postTraversalQueueRef
                       , null <$> readIORef behaviorAssignmentsRef
                       ]
  pure res

-- | Write a value to an event occurrence cache/IORef and schedule it to be cleared.
writeAndScheduleClear :: IORef (Maybe a) -> a -> IO ()
writeAndScheduleClear occRef a = do
  prev <- readIORef occRef
  when (isJust prev) $ error "occRef written twice---loop?"
  writeIORef occRef (Just a)
  addToEnvQueue postTraversalQueueRef $ writeIORef occRef Nothing

-- | See 'runFrame' for how these queues are processed and used.
data Env = Env
  { postTraversalQueueRef :: IORef [IO ()]
  , behaviorInitsRef :: IORef [IO ()]
  , behaviorAssignmentsRef :: IORef [BehaviorAssignment]
  }

{-# NOINLINE theEnv #-}
theEnv :: Env
theEnv = unsafePerformIO $ Env <$> newIORef [] <*> newIORef [] <*> newIORef []

addToEnvQueue :: (Env -> IORef [a]) -> a -> IO ()
addToEnvQueue selector a = modifyIORef (selector theEnv) (a:)

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
module Frp.Test where

import Frp.Impl
import Frp.Class
import Data.Kind (Type)
import Control.Monad.State
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import System.Mem (performGC)
import Witherable (catMaybes)
import Frp.Pure
import Data.Bifunctor (first)
import qualified Data.IntSet as IntSet
import Control.Monad.Fix (MonadFix)
import Data.Maybe (fromMaybe)
import Control.Monad (forM, when, join)
import qualified Data.Map as Map
import System.Exit
import Data.Char (toUpper)
import Data.Functor (void)
import Data.IntSet (IntSet)

newtype PlanImpl a where
  PlanImpl :: (StateT Schedule (Moment Impl) a) -> PlanImpl a
  deriving (Functor,Applicative,Monad,MonadFix)

type Schedule = IntMap [EventTrigger]

newtype PlanPure a = PlanPure (StateT IntSet (Moment (Pure Int)) a)
  deriving (Functor,Applicative,Monad,MonadFix)

instance () => TestPlan Impl PlanImpl where
  plan occurrences = PlanImpl $ do
    (makeTrigger, e) <- liftIO newEvent
    modify . IntMap.unionWith mappend . IntMap.fromList
      . fmap (\(t,a) -> (fromIntegral t, [makeTrigger a]))
      $ occurrences
    pure e
  liftPlan = PlanImpl . lift


mapToPureEvent :: IntMap a -> Event (Pure Int) a
mapToPureEvent m = EventP $ flip IntMap.lookup m

instance TestPlan (Pure Int) PlanPure where
  plan occurrences = do
    let m = IntMap.fromList (first fromIntegral <$> occurrences)
    PlanPure . modify $ IntSet.union (IntMap.keysSet m)
    pure $ mapToPureEvent m
  liftPlan = PlanPure . lift

runPlanImplE :: PlanImpl (Event Impl b) -> IO (IntMap b)
runPlanImplE (PlanImpl x) = do
  (e,s) <- runStateT x mempty
  readOcc <- subscribeEvent e
  catMaybes
    <$> traverse (\occs -> do
                             performGC
                             runFrame occs readOcc)
        (makeDense s)
-- TODO: commonalities between runPlanImpl*
runPlanImplB :: PlanImpl (Behavior Impl b) -> IO (IntMap b)
runPlanImplB (PlanImpl x) = do
  (b,s) <- runStateT x mempty
  traverse (\occs -> do
               performGC
               runFrame occs (readBehavior b))
    (makeDense s)

runPure :: PlanPure a -> (a, IntSet)
runPure (PlanPure p) = runStateT p mempty 0

relevantTimes :: IntSet -> IntSet
relevantTimes occs = IntSet.fromList [0..l + 1]
  where l = maybe 0 fst (IntSet.maxView occs)

testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a
testBehavior (b, occs) = IntMap.fromSet (sample b) (relevantTimes occs)

testEvent :: (Event (Pure Int) a, IntSet) -> IntMap a
testEvent (EventP readEvent, occs) = catMaybes $ IntMap.fromSet readEvent (relevantTimes occs)


makeDense :: IntMap [a] -> IntMap [a]
makeDense s = fromMaybe (emptyRange 0) $ do
  (end, _) <- fst <$> IntMap.maxViewWithKey s
  return $ IntMap.union s (emptyRange end)
    where
      emptyRange end = IntMap.fromList (map (, []) [0..end + 1])


class (Frp t, Monad m, MonadFix m) => TestPlan (t :: Type) m | m -> t where
  plan :: [(Word, a)] -> m (Event t a)
  liftPlan :: Moment t a -> m a

planList :: TestPlan t m => [a] -> m (Event t a)
planList xs = plan $ zip [1..] xs

type TestE a = forall t m. TestPlan t m => m (Event t a)
type TestB a = forall t m. TestPlan t m => m (Behavior t a)

data TestCase  where
  TestE  :: (Show a, Eq a) => TestE a -> TestCase
  TestB  :: (Show a, Eq a) => TestB a -> TestCase

-- Helpers to declare test cases
testE :: (Eq a, Show a) => String -> TestE a -> (String, TestCase)
testE name test = (name, TestE test)

testB :: (Eq a, Show a) => String -> TestB a -> (String, TestCase)
testB name test = (name, TestB test)


testAgreement :: TestCase -> IO Bool
testAgreement = \case
  TestE p -> do
    impl <- runPlanImplE p
    let results = [("impl", impl)]
    compareResult results (testEvent $ runPure p)
  TestB p -> do
    impl <- runPlanImplB p
    let results = [("impl", impl)]
    compareResult results (testBehavior $ runPure p)

compareResult :: (Show a, Eq a) => [(String, IntMap a)] -> IntMap a -> IO Bool
compareResult results expected = fmap and $ forM results $ \(name, r) -> do
  when (r /= expected) $ do
    putStrLn ("Got: " ++ show (name, r))
    putStrLn ("Expected: " ++ show expected)
  pure (r == expected)

runTests :: [(String, TestCase)] -> IO ()
runTests cases = do
   results <- forM cases $ \(name, test) -> do
     putStrLn $ "Test: " <> name
     testAgreement test
   exitWith $ if and results
              then ExitSuccess
              else ExitFailure 1

testCases :: [(String, TestCase)]
testCases =
  [ testB "hold-0"  $ liftPlan . hold "0" =<< events1
  , testB "count" $ do
      b <- liftPlan . count =<< events2
      pure $ (+ (0::Int)) <$> b
  , testB "behavior-0" $ liftA2 (<>) <$> behavior1 <*> behavior2
  , testB "behavior-1" $ do
      es <- planList ["a", "b", "c"]
      e <- plan [(0, ())]
      b <- liftPlan $ hold (pure "") $
        mapMoment (const $ hold "z" es) e
      pure (join b)
  , testE "id" events2
  , testE "fmap-simple" $ fmap (<> "x") <$> events2
  , testE "tag-1" $ (<@) <$> behavior1 <*> events2
  , testE "tag-2" $ (<@) <$> (fmap (fmap toUpper) <$> behavior1) <*> events2
  , testE "attach-1" $ do
      b1 <- behavior1
      attachWith (++) (fmap toUpper <$> b1) <$> events2
  , testE "leftmost" $ liftA2 leftmost2 events1 events2

  , testE "appendEvents-1" $ liftA2 mappend events1 events2

  , testE "appendEvents-2" $ liftA2 mappend events3 events2

  , testE "merge-1" $ do
      e <- events1
      pure $ leftmost ["x" <$ e, "y" <$ e]

  , testE "merge-2" $ do
      e <- events1
      let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)]
      let ee = flip mapMoment e $ const $ pure m
      pure $ coincidence ee

  , testE "headE-0" $ liftPlan . headE =<< events1
  , testE "headE-1" $ do
      e <- events1
      liftPlan $ headE $ leftmost [e, e]

  , testE "headE-2" $ do
      e <- events1
      liftPlan $ do b <- hold never (e <$ e)
                    headE $ switch b

  , testE "switch-1" $ do
      e <- events1
      b <- liftPlan $ hold never (e <$ e)
      pure $ switch b

  , testE "switch-2" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $ const $ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) (e <$ e)

  , testE "switch-3" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $ const $ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) never

  , testE "switch-4" $ do
      e <- events1
      liftPlan $ switch <$> hold (deep e) (e <$ e)

  , testE "switch-5" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $ const $
        pure $ leftmost ["x" <$ e, "y" <$ e, "z" <$ e]

  , testE "switch-6" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $ const $ switch <$> hold ("x" <$ e) (e <$ e)

  , testE "switchHoldPromptly-1" $ do
      e <- events1
      let e' = e <$ e
      liftPlan $ switchHoldPromptly never $ e <$ e'

  , testE "switchHoldPromptly-2" $ do
      e <- events1
      liftPlan $ switchHoldPromptly never $ deep (e <$ e)

  , testE "switchHoldPromptly-3" $ do
      e <- events1
      liftPlan $ switchHoldPromptly never (e <$ deep e)

  , testE "switchHoldPromptly-4" $ do
      e <- events1
      liftPlan $ switchHoldPromptly never (deep e <$ e)

  , testE "switch-6" $ do
      e <- events1
      liftPlan $ switch <$> hold never (deep e <$ e)

  , testE "switchHoldPromptly-5" $ do
    e <- events1
    liftPlan $ switchHoldPromptly never $ flip mapMaybeMoment e $
      const (Just <$> headE e)

  , testE "switchHoldPromptly-6" $ do
      e <- events1
      liftPlan $ switchHoldPromptly never $ flip mapMoment e $
        const (switchHoldPromptly e never)

  , testE "coincidence-1" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $
        const $ pure e

  , testE "coincidence-2" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $
        const $ pure (deep e)

  , testE "coincidence-3" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $
        const $ pure (coincidence (e <$ e))

  , testE "coincidence-4" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $
        const (headE e)

  , testE "coincidence-5" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $ const $ do
        let e' = deep e
        pure (coincidence (e' <$ e'))

  , testE "coincidence-6" $ do
      e <- events1
      pure $ coincidence $ flip mapMoment e $ const $ do
        let e' = coincidence (e <$ e)
        pure $ deep e'

  , testE "coincidence-7" $ do
      e <- events1
      pure $ coincidence (deep e <$ e)

  , testB "holdWhileFiring" $ do
      e <- events1
      liftPlan $  do
        eo <- headE e
        bb <- hold (pure "x") $ mapMoment (const $ hold "a" eo) eo
        pure $ join bb

  , testE "joinDyn" $ do
      e <- events1
      liftPlan $ do
        bb <- hold "b" e
        bd <- hold never . fmap (const e) =<< headE e

        eOuter <- mapMoment sample . fmap (const bb) <$> headE e
        let eInner = switch bd
        pure $ leftmost [eOuter, eInner]

  , testB "holdSampleStrictness"  $ do
      e1 <- events1
      liftPlan $ do
        rec
          a <- sample b
          b' <- hold a e1
          b <- hold "0" e1
          _ <- sample b'
        pure b'

  , testE "difference" $ do
      e1 <- events1
      e2 <- events2
      pure $ e1 `difference ` e2

  , testE "lazy-hold" $ do
      let lazyHold :: forall t. (Frp t) => Moment t (Event t ())
          lazyHold = do
            rec !b <- hold never e
                let e = never <$ switch b
            pure $ void e
      liftPlan lazyHold
  , testE "now-1" $ do
      e1 <- events1
      liftPlan $ switchHoldPromptly never . mapMoment (\a -> fmap (a <$) now) $ e1
  , testE "now-2" $ do
      e1 <- events1
      let e = mapMoment (\a -> if a == "a" then now else pure never) e1
      x <- liftPlan $ accumE (<>) never e
      pure . coincidence $ x
  , testE "now-3" $ liftPlan now
  , testE "now-4" $ do
      coincidence . mapMoment (\a -> if a == "a" then now else pure never) <$> events1

  ]  where
    events1, events2, events3 ::  TestPlan t m => m (Event t String)
    events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]
    events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]
    events3 = liftA2 mappend events1 events2

    behavior1, behavior2 :: forall t m. TestPlan t m => m (Behavior t String)
    behavior1 =  liftPlan . hold "1" =<< events1
    behavior2 =  liftPlan . hold "2" =<< events2

    deep e = leftmost [e, e]
    leftmost2 e1 e2 = leftmost [e1, e2]