Trans.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

module Descript.Misc.Error.Result.Trans
  ( ResultT (..)
  , UResultT
  , mkSuccessT
  , mkFailureT
  , mkUFailureT
  , maybeToResultT
  , mapErrorT
  ) where

import Descript.Misc.Error.Result.Base
import Control.Monad.Trans.Class
import Core.Control.Monad.Trans
import Control.Monad

-- | Either produces a value and fails, and performs some side effect
-- while doing /either/.
newtype ResultT e u a = ResultT{ runResultT :: u (Result e a) } deriving (Functor)

type UResultT u a = ResultT () u a

instance (Applicative u) => Applicative (ResultT e u) where
  pure = ResultT . pure . Success
  ResultT f <*> ResultT x = ResultT $ (<*>) <$> f <*> x

instance (Monad u) => Monad (ResultT e u) where
  return = ResultT . return . Success
  ResultT x >>= f = ResultT $ x >>= f'
    where f' (Failure err) = pure $ Failure err
          f' (Success val) = runResultT $ f val

instance MonadTrans (ResultT e) where
  lift = ResultT . fmap pure

instance MonadHoist (ResultT e) where
  mapInner f (ResultT x) = ResultT $ f x

instance (e1 ~ e2) => MonadTransBridge (Result e1) (ResultT e2) where
  hoist = ResultT . pure
  bindStackOuter f = ResultT . join . fmap (runResultT . f) . runResultT

-- | A lifted success with the given value.
mkSuccessT :: (Monad u) => a -> ResultT e u a
mkSuccessT = hoist . Success

-- | A lifted failure with the given error.
mkFailureT :: (Monad u) => e -> ResultT e u a
mkFailureT = hoist . Failure

-- | A lifted failure with no error details.
mkUFailureT :: (Monad u) => UResultT u a
mkUFailureT = mkFailureT ()

-- | If 'Just', a lifted success. If 'Nothing', a lifted failure with
-- the given error.
maybeToResultT :: (Monad u) => e -> Maybe a -> ResultT e u a
maybeToResultT err = hoist . maybeToResult err

-- | If the result is a 'Failure', transforms the error.
mapErrorT :: (Functor u) => (e1 -> e2) -> ResultT e1 u a -> ResultT e2 u a
mapErrorT = mapResultT . mapError

mapResultT :: (Functor u)
           => (Result e1 a -> Result e2 b)
           -> ResultT e1 u a
           -> ResultT e2 u b
mapResultT f = ResultT . fmap f . runResultT