content: -- |
  -- Module:     Control.Wire.Session
  -- Copyright:  (c) 2013 Ertugrul Soeylemez
  -- License:    BSD3
  -- Maintainer: Ertugrul Soeylemez <es@ertes.de>
  
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE DeriveFoldable #-}
  {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE DeriveTraversable #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FunctionalDependencies #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  
  module Control.Wire.Session
      ( -- * State delta types
        HasTime(..),
        Session(..),
  
        -- ** Wires with time
        Timed(..),
        clockSession,
        clockSession_,
        countSession,
        countSession_
      )
      where
  
  import Control.Applicative
  import Control.Monad.IO.Class
  import Data.Data
  import Data.Foldable (Foldable)
  import Data.Semigroup
  import Data.Time.Clock
  import Data.Traversable (Traversable)
  
  
  -- | State delta types with time deltas.
  
  class (Monoid s, Real t) => HasTime t s | s -> t where
      -- | Extract the current time delta.
      dtime :: s -> t
  
  
  -- | State delta generators as required for wire sessions, most notably
  -- to generate time deltas.  These are mini-wires with the sole purpose
  -- of generating these deltas.
  
  newtype Session m s =
      Session {
        stepSession :: m (s, Session m s)
      }
      deriving (Functor)
  
  instance (Applicative m) => Applicative (Session m) where
      pure x = let s = Session (pure (x, s)) in s
  
      Session ff <*> Session fx =
          Session $ liftA2 (\(f, sf) (x, sx) -> (f x, sf <*> sx)) ff fx
  
  
  -- | This state delta type denotes time deltas.  This is necessary for
  -- most FRP applications.
  
  data Timed t s = Timed t s
      deriving (Data, Eq, Foldable, Functor,
                Ord, Read, Show, Traversable, Typeable)
  
  instance (Semigroup s, Monoid s, Real t) => HasTime t (Timed t s) where
      dtime (Timed dt _) = dt
  
  instance (Semigroup s, Num t) => Semigroup (Timed t s) where
      Timed dt1 ds1 <> Timed dt2 ds2 =
          let dt = dt1 + dt2
              ds = ds1 <> ds2
          in dt `seq` ds `seq` Timed dt ds
  
  instance (Semigroup s, Monoid s, Num t) => Monoid (Timed t s) where
      mempty = Timed 0 mempty
      mappend = (<>)
  
  -- | State delta generator for a real time clock.
  
  clockSession :: (MonadIO m) => Session m (s -> Timed NominalDiffTime s)
  clockSession =
      Session $ do
          t0 <- liftIO getCurrentTime
          return (Timed 0, loop t0)
  
      where
      loop t' =
          Session $ do
              t <- liftIO getCurrentTime
              let dt = diffUTCTime t t'
              dt `seq` return (Timed dt, loop t)
  
  
  -- | Non-extending version of 'clockSession'.
  
  clockSession_ :: (Applicative m, MonadIO m) => Session m (Timed NominalDiffTime ())
  clockSession_ = clockSession <*> pure ()
  
  
  -- | State delta generator for a simple counting clock.  Denotes a fixed
  -- framerate.  This is likely more useful than 'clockSession' for
  -- simulations and real-time games.
  
  countSession ::
      (Applicative m)
      => t  -- ^ Increment size.
      -> Session m (s -> Timed t s)
  countSession dt =
      let loop = Session (pure (Timed dt, loop))
      in loop
  
  
  -- | Non-extending version of 'countSession'.
  
  countSession_ :: (Applicative m) => t -> Session m (Timed t ())
  countSession_ dt = countSession dt <*> pure ()
  