Classes.hs

-- |
-- Module:     Control.Wire.Classes
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Type classes used in Netwire.

module Control.Wire.Classes
    ( -- * Various effects
      -- ** Time
      MonadClock(..),
      -- ** Underlying monad
      ArrowKleisli(..),
      arrIO
    )
    where

import Control.Applicative
import Control.Arrow
import Control.Arrow.Transformer
import Control.Arrow.Transformer.Automaton
import Control.Arrow.Transformer.Error
import Control.Arrow.Transformer.Reader
import Control.Arrow.Transformer.State
import Control.Arrow.Transformer.Static
import Control.Arrow.Transformer.Writer
import Control.Monad.Trans (MonadIO(..))
import Data.Monoid
import Data.Time.Clock.POSIX


-- | Monads with a clock.

class Monad m => MonadClock t m | m -> t where
    -- | Current time in some monad-specific frame of reference.
    getTime :: m t


-- | Instance for the system time.  This is intentionally specific to
-- allow you to define better instances with custom monads.

instance MonadClock Double IO where
    getTime = fmap realToFrac getPOSIXTime


-- | Arrows which support running monadic computations.

class Arrow (>~) => ArrowKleisli m (>~) | (>~) -> m where
    -- | Run the input computation and output its result.
    arrM :: Monad m => m b >~ b

instance Monad m => ArrowKleisli m (Kleisli m) where
    arrM = Kleisli id

instance ArrowKleisli m (>~) => ArrowKleisli m (Automaton (>~)) where
    arrM = lift arrM

instance (ArrowChoice (>~), ArrowKleisli m (>~)) => ArrowKleisli m (ErrorArrow ex (>~)) where
    arrM = lift arrM

instance ArrowKleisli m (>~) => ArrowKleisli m (ReaderArrow e (>~)) where
    arrM = lift arrM

instance ArrowKleisli m (>~) => ArrowKleisli m (StateArrow s (>~)) where
    arrM = lift arrM

instance (Applicative f, ArrowKleisli m (>~)) => ArrowKleisli m (StaticArrow f (>~)) where
    arrM = lift arrM

instance (ArrowKleisli m (>~), Monoid l) => ArrowKleisli m (WriterArrow l (>~)) where
    arrM = lift arrM


-- | Arrows, which have 'IO' at their base.

arrIO :: (ArrowKleisli m (>~), MonadIO m) => IO b >~ b
arrIO = arrM <<^ liftIO