Except.hs

{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveTraversable, DerivingVia #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Control.Selective.Trans.Except
-- Copyright  : (c) Andrey Mokhov 2018-2024
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- Stability  : experimental
--
-- This is a library for /selective applicative functors/, or just
-- /selective functors/ for short, an abstraction between applicative functors
-- and monads, introduced in this paper: https://dl.acm.org/doi/10.1145/3341694.
--
-- This module defines a newtype around 'ExceptT' from @transformers@ with less
-- restrictive 'Applicative', 'Selective', and 'Alternative' implementations.
-- It supplies an @instance 'Selective' f => 'Selective' ('ExceptT' e f)@, which
-- makes 'ExceptT' a bona-fide 'Selective' transformer.
--
-- The API follows the API from the @transformers@ package, so it can be used as
-- a drop-in replacement. The documentation can be found in the
-- [@transformers@](https://hackage.haskell.org/package/transformers/docs/Control-Monad-Trans-Except.html) package.
-----------------------------------------------------------------------------
module Control.Selective.Trans.Except where

import Control.Applicative (Alternative)
import Control.Monad (MonadPlus)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Zip (MonadZip)
import Data.Functor.Classes
import Data.Functor.Contravariant (Contravariant)
import Data.Functor.Identity
#if MIN_VERSION_base(4,13,0)
-- MonadFail is imported already
#else
import Control.Monad.Fail
#endif

import qualified Control.Monad.Trans.Except as T

import Control.Selective
import Control.Monad.Signatures

-- | A newtype wrapper around 'T.ExceptT' from @transformers@ that provides less
-- restrictive 'Applicative', 'Selective' and 'Alternative' instances.
newtype ExceptT e f a = ExceptT { unwrap :: T.ExceptT e f a }
  deriving stock (Functor, Foldable, Traversable, Eq, Ord, Read, Show)
  deriving newtype
    (Monad, Contravariant, MonadFix, MonadFail, MonadZip, MonadIO, MonadPlus
    , Eq1, Ord1, Read1, Show1 ) -- These require -Wno-redundant-constraints
  deriving (Applicative, Selective, Alternative) via (ComposeEither f e)

{- Why don't we provide a `MonadTrans (ExceptT e)` instance?

   Recall the definition of the MonadTrans type class:

     class (forall m. Monad m => Monad (t m)) => MonadTrans t where
         lift :: Monad m => m a -> t m a

   If we instantiate `t` to `ExceptT e` in the constraint, we get

     forall m. Monad m => Monad (ExceptT e m)

   but the `Applicative (ExceptT e m)` instance comes with the `Selective m`
   constraint, and since Selective is not a superclass of Monad, we're stuck.
   In other words, `ExceptT` is really not a universal monad transformer: it
   works only for monads `m` that also happen to have a `Selective m` instance.

   I can see three possible solutions but none of them has a chance of working
   in practice:

     * Change the constraint in the definition of MonadTrans to

         forall m. (Selective m, Monad m) => Monad (ExceptT e m)

     * Make Selective a superclass of Monad
     * Revert the "Applicative is a superclass of Monad" proposal (lol!)

   And so we just don't provide `MonadTrans (ExceptT e)` instance.

   We could provide a SelectiveTrans instance instead, where

     class (forall f. Selective f => Selective (t f)) => SelectiveTrans t where
         lift :: Selective f => f a -> t f a

   Sounds fun!
-}

-- | Inject an 'T.ExceptT' value into the newtype wrapper.
wrap :: T.ExceptT e m a -> ExceptT e m a
wrap = ExceptT

type Except e = ExceptT e Identity

except :: Monad m => Either e a -> ExceptT e m a
except = ExceptT . T.except

runExcept :: Except e a -> Either e a
runExcept = T.runExcept . unwrap

mapExcept :: (Either e a -> Either e' b) -> Except e a -> Except e' b
mapExcept f = ExceptT . T.mapExcept f . unwrap

withExcept :: (e -> e') -> Except e a -> Except e' a
withExcept f = ExceptT . T.withExcept f . unwrap

runExceptT :: ExceptT e m a -> m (Either e a)
runExceptT = T.runExceptT . unwrap

mapExceptT :: (m (Either e a) -> n (Either e' b)) -> ExceptT e m a -> ExceptT e' n b
mapExceptT f = ExceptT . T.mapExceptT f . unwrap

withExceptT :: Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT f = ExceptT . T.withExceptT f . unwrap

throwE :: Monad m => e -> ExceptT e m a
throwE = ExceptT . T.throwE

catchE :: Monad m => ExceptT e m a -> (e -> ExceptT e' m a) -> ExceptT e' m a
catchE action continuation = ExceptT $ T.catchE (unwrap action) (unwrap . continuation)

liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b
liftCallCC callCC caller = ExceptT $ T.liftCallCC callCC (unwrap . caller . (ExceptT .))

liftListen :: Monad m => Listen w m (Either e a) -> Listen w (ExceptT e m) a
liftListen listen (ExceptT action) = ExceptT $ T.liftListen listen action

liftPass :: Monad m => Pass w m (Either e a) -> Pass w (ExceptT e m) a
liftPass pass (ExceptT action) = ExceptT $ T.liftPass pass action