Classes.hs

-- |
-- Module:     Control.ContStuff.Classes
-- Copyright:  (c) 2010 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
-- Stability:  experimental
--
-- This module implements the various effect classes supported by
-- contstuff.

{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}

module Control.ContStuff.Classes
    ( -- * Effect classes
      -- ** Abortion
      Abortable(..),
      -- ** Call with current continuation
      CallCC(..), Label, labelCC, goto,
      -- ** Multithreading
      -- *** Forking
      Forkable(..),
      -- ** Exceptions
      HasExceptions(..),
      bracket, bracket_, catch, finally, forbid, handle, raiseUnless,
      raiseWhen, require,
      -- ** Functor lifting
      LiftFunctor(..),
      -- ** State
      -- *** Reading
      Readable(..),
      getField,
      -- *** Writing
      Stateful(..),
      modify, modifyField, modifyFieldLazy, modifyLazy,
      -- ** Logging support (writers)
      Writable(..)
    )
    where

import qualified Control.Concurrent as Conc
import Control.Applicative
import Control.Concurrent hiding (forkIO, forkOS)
import Control.Monad
import Control.Monad.Trans.Class
import Prelude hiding (catch)


--------------
-- Abortion --
--------------

-- | Monads supporting abortion.

class Abortable m where
    -- | End result of the computation.
    type Result m

    -- | Ignore current continuation and abort.
    abort :: Result m -> m a


------------
-- CallCC --
------------

-- | Monads supporting *call-with-current-continuation* (aka callCC).

class CallCC m where
    -- | Call with current continuation.
    callCC :: ((a -> m b) -> m a) -> m a


-- | A jump label for 'labelCC' and 'goto'.

newtype Label m a = Label (a -> Label m a -> m ())


-- | Capture the current continuation for later use.

labelCC :: (Applicative m, CallCC m) => a -> m (a, Label m a)
labelCC x = callCC $ \k -> pure (x, Label $ curry k)


-- | Jump to a label.

goto :: Label m a -> a -> m ()
goto lk@(Label k) x = k x lk


---------------------
-- Forkable monads --
---------------------

-- | Monads with support for forking threads.

class Monad m => Forkable m where
    -- | Generalization of 'Conc.forkIO'.
    forkIO :: m () -> m ThreadId

    -- | Generalization of 'Conc.forkOS'.
    forkOS :: m () -> m ThreadId


instance Forkable IO where
    forkIO = Conc.forkIO
    forkOS = Conc.forkOS


----------------
-- Exceptions --
----------------

-- | Monads with exception support.

class HasExceptions m where
    -- | The exception type.
    type Exception m

    -- | Raise an exception.
    raise :: Exception m -> m a

    -- | Run computation catching exceptions.
    try :: m a -> m (Either (Exception m) a)


-- | Get a resource, run a computation, then release the resource, even
-- if an exception is raised:
--
-- > bracket acquire release use
--
-- Please note that this function behaves slightly different from the
-- usual 'E.bracket'.  If both the user and the releaser throw an
-- exception, the user exception is significant.

bracket :: (HasExceptions m, Monad m) => m res -> (res -> m b) -> (res -> m a) -> m a
bracket acquire release use = do
    resource <- acquire
    result <- try (use resource)
    try (release resource)
    either raise return result


-- | Initialize, then run, then clean up safely, even if an exception is
-- raised:
--
-- > bracket_ init cleanup run
--
-- Please note that this function behaves slightly different from the
-- usual 'E.bracket_'.  If both the user and the releaser throw an
-- exception, the user exception is significant.

bracket_ :: (HasExceptions m, Monad m) => m a -> m b -> m c -> m c
bracket_ init cleanup run = do
    init
    result <- try run
    try cleanup
    either raise return result


-- | Catch exceptions using an exception handler.

catch :: (HasExceptions m, Monad m) => m a -> (Exception m -> m a) -> m a
catch c h = try c >>= either h return


-- | Run a final computation regardless of whether an exception was
-- raised.

finally :: (HasExceptions m, Monad m) => m a -> m b -> m a
finally c d = try c >>= either (\exp -> d >> raise exp) (\x -> d >> return x)


-- | Fail (in the sense of the given transformer), if the given
-- underlying computation returns 'True'.

forbid ::
    ( Exception (t m) ~ (), HasExceptions (t m),
      Monad m, Monad (t m), MonadTrans t ) =>
    m Bool -> t m ()
forbid = raiseWhen () . lift


-- | Catch exceptions using an exception handler (flip 'catch').

handle :: (HasExceptions m, Monad m) => (Exception m -> m a) -> m a -> m a
handle h c = try c >>= either h return


-- | Throw given exception, if the given computation returns 'False'.

raiseUnless :: (HasExceptions m, Monad m) => Exception m -> m Bool -> m ()
raiseUnless ex c = do b <- c; unless b (raise ex)


-- | Throw given exception, if the given computation returns 'True'.

raiseWhen :: (HasExceptions m, Monad m) => Exception m -> m Bool -> m ()
raiseWhen ex c = do b <- c; when b (raise ex)


-- | Fail (in the sense of the given transformer), if the given
-- underlying computation returns 'False'.

require ::
    ( Exception (t m) ~ (), HasExceptions (t m),
      Monad m, Monad (t m), MonadTrans t ) =>
    m Bool -> t m ()
require = raiseUnless () . lift


------------------
-- Lift functor --
------------------

-- | Type class for lifting functor computations.

class LiftFunctor t where
    -- | Inner functor.
    type InnerFunctor t :: * -> *

    -- | Unwrap inner functor.
    liftF :: Monad m => m (InnerFunctor t a) -> t m a


-----------
-- State --
-----------

-- | Monads with environment (reader monads).

class Readable m where
    -- | Environment type of @m@.
    type StateOf m

    -- | Get the current state.
    get :: m (StateOf m)


-- | Get a certain field.

getField :: (Functor m, Readable m) => (StateOf m -> a) -> m a
getField = (<$> get)


-- | Stateful monads, i.e. having a modifyable environment (stateful monads).
--
-- Minimal complete definition: 'putLazy'.

class Stateful m where
    -- | Set the current state and force it.
    put :: StateOf m -> m ()
    put x = x `seq` putLazy x

    -- | Set the current state, but don't force it.
    putLazy :: StateOf m -> m ()


-- | Apply a function to the current state.

modify :: (Monad m, Readable m, Stateful m) => (StateOf m -> StateOf m) -> m ()
modify f = liftM f get >>= put


-- | Get a field and modify the state.

modifyField :: (Monad m, Readable m, Stateful m) =>
               (StateOf m -> a) -> (a -> StateOf m) -> m ()
modifyField accessor f = liftM (f . accessor) get >>= put


-- | Get a field and modify the state.  Lazy version.

modifyFieldLazy :: (Monad m, Readable m, Stateful m) =>
                   (StateOf m -> a) -> (a -> StateOf m) -> m ()
modifyFieldLazy accessor f = liftM (f . accessor) get >>= putLazy


-- | Apply a function to the current state.  Lazy version.

modifyLazy :: (Monad m, Readable m, Stateful m) =>
              (StateOf m -> StateOf m) -> m ()
modifyLazy f = liftM f get >>= putLazy


-------------
-- Logging --
-------------

-- | Monads with support for logging.  Traditionally these are called
-- *writer monads*.

class Writable m w where
    -- | Log a value.
    tell :: w -> m ()