Exceptable.hs

{-# LANGUAGE
  GeneralizedNewtypeDeriving,
  MultiParamTypeClasses,
  UndecidableInstances,
  CPP
  #-}

module Control.Monad.Exceptable (
      -- * MonadError class
    MonadError(..),

      -- * The Exceptable monad
    Exceptable,
    exceptable,
    runExceptable,
    mapExceptable,
    withExceptable,
    makeExceptableT,
    -- * The ExceptT monad transformer
    ExceptableT(ExceptableT),
    unExceptableT,
    runExceptableT,
    mapExceptableT,
    withExceptableT,
    -- * Exception operations
    throwE,
    catchE,
    -- * Lifting other operations
    liftCallCC,
    liftListen,
    liftPass,
    -- * underlying ExceptT type
    Except.Except,
    Except.ExceptT,

    module Control.Monad.Fix,
    module Control.Monad.Trans,
    -- * Example 1: Custom Error Data Type
    -- $customErrorExample

    -- * Example 2: Using ExceptT Monad Transformer
    -- $ExceptTExample
    ) where

import Prelude

import qualified Control.Monad.Trans.Except as Except

import Control.Monad.Trans
import Control.Monad.Signatures
import Data.Functor.Classes
import Data.Functor.Identity

import Control.Monad.State.Class as State
import Control.Monad.Error.Class as Error

import Control.Applicative
import Control.Monad
import Control.Monad.Fix
#if __GLASGOW_HASKELL__ < 710
import Data.Foldable
import Data.Traversable (Traversable(traverse))
#endif


{- |
Why does the Exceptable module exist? The present llvm general design
is around the use of the ExceptT transformer, first defined in  transformers 0.4.

Well, the goal of this module is to allow LLVM-General to be compatible with
GHC 7.8 apis, and GHC 7.8 comes bundled with transformers 0.3. Thus LLVM-General
must be compatible with transformers 0.3 (via the use of transformers-compat)
in order to be usable in conjunction with usage of GHC as a library.

At some future point where the active "power users" base of LLVM-General
no longer needs to support GHC 7.8 heavily, removing this Module and reverting other
changes elsewhere to using ExceptT / Except will be a good idea.

A good "signpost" for reverting will be around GHC 7.12's release,
because then there will be >=2 GHC major version releases that come bundled with
Transformers >= 0.4

-}


type Exceptable e = ExceptableT e Identity

-- | Constructor for computations in the exception monad.
-- (The inverse of 'runExcept').
except :: Either e a -> Exceptable e a
except m = makeExceptableT (Identity m)

exceptable :: Except.Except e a -> Exceptable e a
exceptable = ExceptableT

-- | Extractor for computations in the exception monad.
-- (The inverse of 'except').
runExceptable :: Exceptable e a -> Either e a
runExceptable (ExceptableT m) = runIdentity $ Except.runExceptT m

-- | Map the unwrapped computation using the given function.
--
-- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@
mapExceptable :: (Either e a -> Either e' b)
        -> Exceptable e a
        -> Exceptable e' b
mapExceptable f = mapExceptableT (Identity . f . runIdentity)

-- | Transform any exceptions thrown by the computation using the given
-- function (a specialization of 'withExceptT').
withExceptable :: (e -> e') -> Exceptable e a -> Exceptable e' a
withExceptable = withExceptableT



newtype ExceptableT e m a = ExceptableT { unExceptableT :: Except.ExceptT  e m a }
  deriving (
    Eq,
    Eq1,
    Ord,
    Ord1,
    Functor,
    Foldable,
    Applicative,
    Alternative,
    Monad,
    MonadPlus,
    MonadTrans,
    MonadIO
    )

instance MonadState s m => MonadState s (ExceptableT e m) where
    get = lift get
    put = lift . put
    state = lift . state

instance Monad m => MonadError e (ExceptableT e m) where
    throwError = throwE
    catchError = catchE

instance (Traversable f) => Traversable (ExceptableT e f) where
    traverse f a =
        (ExceptableT . Except.ExceptT) <$>
          traverse (either (pure . Left) (fmap Right . f)) (runExceptableT a)


instance (Read e, Read1 m, Read a) => Read (ExceptableT e m a) where
    readsPrec = readsData $ readsUnary1 "ExceptableT" ExceptableT

instance (Show e, Show1 m, Show a) => Show (ExceptableT e m a) where
    showsPrec d (ExceptableT m) = showsUnary1 "ExceptableT" d m

instance (Read e, Read1 m) => Read1 (ExceptableT e m) where readsPrec1 = readsPrec
instance (Show e, Show1 m) => Show1 (ExceptableT e m) where showsPrec1 = showsPrec

runExceptableT :: ExceptableT e m a -> m (Either e a)
runExceptableT =  Except.runExceptT . unExceptableT

makeExceptableT :: m (Either e a) -> ExceptableT e m a
makeExceptableT = ExceptableT . Except.ExceptT




-- | Map the unwrapped computation using the given function.
--
-- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@
mapExceptableT :: (m (Either e a) -> n (Either e' b))
        -> ExceptableT e m a
        -> ExceptableT e' n b
mapExceptableT f m = makeExceptableT $ f (runExceptableT m)

-- | Transform any exceptions thrown by the computation using the
-- given function.
withExceptableT :: (Functor m) => (e -> e') -> ExceptableT e m a -> ExceptableT e' m a
withExceptableT f = mapExceptableT $ fmap $ either (Left . f) Right


-- | Signal an exception value @e@.
--
-- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@
--
-- * @'throwE' e >>= m = 'throwE' e@
throwE :: (Monad m) => e -> ExceptableT e m a
throwE = makeExceptableT . return . Left

-- | Handle an exception.
--
-- * @'catchE' h ('lift' m) = 'lift' m@
--
-- * @'catchE' h ('throwE' e) = h e@
catchE :: (Monad m) =>
    ExceptableT e m a               -- ^ the inner computation
    -> (e -> ExceptableT e' m a)    -- ^ a handler for exceptions in the inner
                                -- computation
    -> ExceptableT e' m a
m `catchE` h = makeExceptableT $ do
    a <- runExceptableT m
    case a of
        Left  l -> runExceptableT (h l)
        Right r -> return (Right r)

-- | Lift a @callCC@ operation to the new monad.
liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptableT e m) a b
liftCallCC callCC f = makeExceptableT $
    callCC $ \ c ->
    runExceptableT (f (\ a -> makeExceptableT $ c (Right a)))

-- | Lift a @listen@ operation to the new monad.
liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptableT e m) a
liftListen listen = mapExceptableT $ \ m -> do
    (a, w) <- listen m
    return $! fmap (\ r -> (r, w)) a

-- | Lift a @pass@ operation to the new monad.
liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptableT e m) a
liftPass pass = mapExceptableT $ \ m -> pass $ do
    a <- m
    return $! case a of
        Left l -> (Left l, id)
        Right (r, f) -> (Right r, f)