SEvent.hs

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving
  , FlexibleInstances, FlexibleContexts, TypeSynonymInstances
  , MultiParamTypeClasses
  #-}

----------------------------------------------------------------------
-- |
-- Module      :  Data.SEvent
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Denotational semantics for events
----------------------------------------------------------------------

module Data.SEvent
  (
    -- * Event primitives
    Event'(..), accumE
  ) where

import Data.Monoid
import Control.Applicative
import Control.Monad

-- TypeCompose
import Control.Compose (Binop,DistribM(..))

import Data.SFuture


{----------------------------------------------------------
    Event primitives
----------------------------------------------------------}

-- | Generalized 'Event' over arbitrary (ordered) time type.  See also
-- 'Event\''. 
newtype Event' t a = E { unE :: [Future t a] }

-- | Apply a unary function within the 'Ascend' constructor.
inE :: ([Future t a] -> [Future t b]) -> (Event' t a -> Event' t b)
inE f = E . f . unE

-- | Apply a binary function within the 'E' constructor.
inE2 :: ([Future t a] -> [Future t b] -> [Future t c])
     -> (Event' t a -> Event' t b -> Event' t c)
inE2 f = inE . f . unE


-- Note: the semantics of Applicative and Monad are not consistent with
-- 
--   type Event = [] :. Fut
-- 
-- because that composition would combine future values with []-style
-- backtracking instead of temporal interleaving.
-- 
-- However, maybe there's a []-wrapping newtype I can use instead.

instance Ord t => Monoid (Event' t a) where
  mempty  = E []
  mappend = inE2 merge

instance Functor (Event' t) where
  fmap f = inE ((fmap.fmap) f)

instance Ord t => Applicative (Event' t) where
  pure  = return
  (<*>) = ap

instance Ord t => Monad (Event' t) where
  return a = E ((return.return) a)
  e >>= f  = joinE (f <$> e)

-- This MonadPlus instance could go in EventExtras, but it would be an
-- orphan there.
instance Ord t => MonadPlus (Event' t) where { mzero = mempty; mplus = mappend }

-- For monad compositions.
-- We'll need this instance in MEvent.  It'd be an orphan there.
instance Ord t => DistribM (Event' t) Maybe where
  -- distribM :: Maybe (Event' t b) -> Event' t (Maybe b)
  distribM = maybe mempty (fmap Just)

-- | Equivalent to 'join' for 'Event'.  More efficient?
joinE :: Ord t => Event' t (Event' t a) -> Event' t a
joinE = inE $ concatF . (fmap.fmap) unE

-- Derivation:
-- 
--       Event (Event a) 
--   --> [Fut (Event a)]  -- unE
--   --> [Fut [Fut a]]    -- (fmap.fmap) unE
--   --> [Fut a]          -- concatF
--   --> Event a          -- E

-- My previous attempt:

-- joinE :: Ord t => Event' t (Event' t a) -> Event' t a
-- joinE = mconcat . fmap (E . fmap join . sequenceF . fmap unE) . unE
--
-- Derivation:
-- 
--       Event (Event a) 
--   --> [Fut (Event a)]  -- unE
--   --> [Fut [Fut a]]    -- (fmap.fmap) unE
--   --> [[Fut (Fut a)]]  -- fmap sequenceF
--   --> [[Fut a]]        -- (fmap.fmap) join
--   --> [Event a]        -- fmap E
--   --> Event a          -- mconcat

-- I don't think joinE works as I want.  The join on Fut makes sure that
-- the inner occurrences follow the outer, but I don't think fact is
-- visible to the implementation.  Also, note that the mconcat could have
-- an infinite number of lists to merge.

flatFFs :: Ord t => Future t [Future t a] -> [Future t a]
flatFFs = fmap join . sequenceF

concatF :: Ord t => [Future t [Future t a]] -> [Future t a]
concatF = futVal . foldr mergeF (pure [])

-- Binary merge.  The second argument is required to have the property
-- that sub-futures are all at least as late as the containing future.
-- The result is then guaranteed to have the same property, which allows
-- use of futVal instead of flatFFs in concatF.
mergeF :: Ord t => Binop (Future t [Future t a])
ffa `mergeF` Future (tb,futbs) =
  -- First the a values before tb, then interleave the rest of the a
  -- values with the b values.  
  Future (futTime ffa, prefa ++ (suffa `merge` futbs))
 where
   (prefa,suffa) = span ((<= tb).futTime) (flatFFs ffa)

-- TODO: try out a more efficient version of mergeF that doesn't use
-- (++).  Idea: add a span to Data.DList and use it.  Efficient &
-- elegant.


-- | Accumulating event, starting from an initial value and a
-- update-function event.  See also 'accumR'.
accumE :: Ord t => a -> Event' t (a -> a) -> Event' t a
accumE a = inE $ \ futfs -> accum (pure a) (fmap (<*>) futfs)


{--------------------------------------------------------------------
    Misc utilities
--------------------------------------------------------------------}

-- | Merge two ordered lists into an ordered list.
merge :: Ord a => [a] -> [a] -> [a]
[]         `merge` vs         = vs
us         `merge` []         = us
us@(u:us') `merge` vs@(v:vs') =
  if u <= v then
    u : (us' `merge` vs )
  else
    v : (us  `merge` vs')


accum :: a -> [a->a] -> [a]
accum _ [] = []
accum a (f:fs) = a' : accum a' fs where a' = f a

-- or
--   accum a = tail . scanl (flip ($)) a