{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Cli.Extras.SubExcept where

import Control.Lens (Prism', preview, review)
import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.Reader
import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
#if !(MIN_VERSION_base(4, 13, 0))
import Control.Monad.Fail (MonadFail)
#endif
import Control.Monad.Log

-- | Wrap a Prism' in a newtype to avoid impredicativity problems
newtype WrappedPrism' a b = WrappedPrism' { forall a b. WrappedPrism' a b -> Prism' a b
unWrappedPrism' :: Prism' a b }

newtype SubExceptT e eSub m a = SubExceptT { forall e eSub (m :: * -> *) a.
SubExceptT e eSub m a -> ReaderT (WrappedPrism' e eSub) m a
unSubExceptT :: ReaderT (WrappedPrism' e eSub) m a }
  deriving ((forall a b.
 (a -> b) -> SubExceptT e eSub m a -> SubExceptT e eSub m b)
-> (forall a b.
    a -> SubExceptT e eSub m b -> SubExceptT e eSub m a)
-> Functor (SubExceptT e eSub m)
forall a b. a -> SubExceptT e eSub m b -> SubExceptT e eSub m a
forall a b.
(a -> b) -> SubExceptT e eSub m a -> SubExceptT e eSub m b
forall e eSub (m :: * -> *) a b.
Functor m =>
a -> SubExceptT e eSub m b -> SubExceptT e eSub m a
forall e eSub (m :: * -> *) a b.
Functor m =>
(a -> b) -> SubExceptT e eSub m a -> SubExceptT e eSub m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall e eSub (m :: * -> *) a b.
Functor m =>
(a -> b) -> SubExceptT e eSub m a -> SubExceptT e eSub m b
fmap :: forall a b.
(a -> b) -> SubExceptT e eSub m a -> SubExceptT e eSub m b
$c<$ :: forall e eSub (m :: * -> *) a b.
Functor m =>
a -> SubExceptT e eSub m b -> SubExceptT e eSub m a
<$ :: forall a b. a -> SubExceptT e eSub m b -> SubExceptT e eSub m a
Functor, Functor (SubExceptT e eSub m)
Functor (SubExceptT e eSub m) =>
(forall a. a -> SubExceptT e eSub m a)
-> (forall a b.
    SubExceptT e eSub m (a -> b)
    -> SubExceptT e eSub m a -> SubExceptT e eSub m b)
-> (forall a b c.
    (a -> b -> c)
    -> SubExceptT e eSub m a
    -> SubExceptT e eSub m b
    -> SubExceptT e eSub m c)
-> (forall a b.
    SubExceptT e eSub m a
    -> SubExceptT e eSub m b -> SubExceptT e eSub m b)
-> (forall a b.
    SubExceptT e eSub m a
    -> SubExceptT e eSub m b -> SubExceptT e eSub m a)
-> Applicative (SubExceptT e eSub m)
forall a. a -> SubExceptT e eSub m a
forall a b.
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m a
forall a b.
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
forall a b.
SubExceptT e eSub m (a -> b)
-> SubExceptT e eSub m a -> SubExceptT e eSub m b
forall a b c.
(a -> b -> c)
-> SubExceptT e eSub m a
-> SubExceptT e eSub m b
-> SubExceptT e eSub m c
forall e eSub (m :: * -> *).
Applicative m =>
Functor (SubExceptT e eSub m)
forall e eSub (m :: * -> *) a.
Applicative m =>
a -> SubExceptT e eSub m a
forall e eSub (m :: * -> *) a b.
Applicative m =>
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m a
forall e eSub (m :: * -> *) a b.
Applicative m =>
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
forall e eSub (m :: * -> *) a b.
Applicative m =>
SubExceptT e eSub m (a -> b)
-> SubExceptT e eSub m a -> SubExceptT e eSub m b
forall e eSub (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> SubExceptT e eSub m a
-> SubExceptT e eSub m b
-> SubExceptT e eSub m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall e eSub (m :: * -> *) a.
Applicative m =>
a -> SubExceptT e eSub m a
pure :: forall a. a -> SubExceptT e eSub m a
$c<*> :: forall e eSub (m :: * -> *) a b.
Applicative m =>
SubExceptT e eSub m (a -> b)
-> SubExceptT e eSub m a -> SubExceptT e eSub m b
<*> :: forall a b.
SubExceptT e eSub m (a -> b)
-> SubExceptT e eSub m a -> SubExceptT e eSub m b
$cliftA2 :: forall e eSub (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> SubExceptT e eSub m a
-> SubExceptT e eSub m b
-> SubExceptT e eSub m c
liftA2 :: forall a b c.
(a -> b -> c)
-> SubExceptT e eSub m a
-> SubExceptT e eSub m b
-> SubExceptT e eSub m c
$c*> :: forall e eSub (m :: * -> *) a b.
Applicative m =>
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
*> :: forall a b.
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
$c<* :: forall e eSub (m :: * -> *) a b.
Applicative m =>
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m a
<* :: forall a b.
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m a
Applicative, Applicative (SubExceptT e eSub m)
Applicative (SubExceptT e eSub m) =>
(forall a b.
 SubExceptT e eSub m a
 -> (a -> SubExceptT e eSub m b) -> SubExceptT e eSub m b)
-> (forall a b.
    SubExceptT e eSub m a
    -> SubExceptT e eSub m b -> SubExceptT e eSub m b)
-> (forall a. a -> SubExceptT e eSub m a)
-> Monad (SubExceptT e eSub m)
forall a. a -> SubExceptT e eSub m a
forall a b.
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
forall a b.
SubExceptT e eSub m a
-> (a -> SubExceptT e eSub m b) -> SubExceptT e eSub m b
forall e eSub (m :: * -> *).
Monad m =>
Applicative (SubExceptT e eSub m)
forall e eSub (m :: * -> *) a.
Monad m =>
a -> SubExceptT e eSub m a
forall e eSub (m :: * -> *) a b.
Monad m =>
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
forall e eSub (m :: * -> *) a b.
Monad m =>
SubExceptT e eSub m a
-> (a -> SubExceptT e eSub m b) -> SubExceptT e eSub m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall e eSub (m :: * -> *) a b.
Monad m =>
SubExceptT e eSub m a
-> (a -> SubExceptT e eSub m b) -> SubExceptT e eSub m b
>>= :: forall a b.
SubExceptT e eSub m a
-> (a -> SubExceptT e eSub m b) -> SubExceptT e eSub m b
$c>> :: forall e eSub (m :: * -> *) a b.
Monad m =>
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
>> :: forall a b.
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
$creturn :: forall e eSub (m :: * -> *) a.
Monad m =>
a -> SubExceptT e eSub m a
return :: forall a. a -> SubExceptT e eSub m a
Monad, Monad (SubExceptT e eSub m)
Monad (SubExceptT e eSub m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 e -> SubExceptT e eSub m a)
-> MonadThrow (SubExceptT e eSub m)
forall e a.
(HasCallStack, Exception e) =>
e -> SubExceptT e eSub m a
forall e eSub (m :: * -> *).
MonadThrow m =>
Monad (SubExceptT e eSub m)
forall e eSub (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> SubExceptT e eSub m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e eSub (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> SubExceptT e eSub m a
throwM :: forall e a.
(HasCallStack, Exception e) =>
e -> SubExceptT e eSub m a
MonadThrow, MonadThrow (SubExceptT e eSub m)
MonadThrow (SubExceptT e eSub m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 SubExceptT e eSub m a
 -> (e -> SubExceptT e eSub m a) -> SubExceptT e eSub m a)
-> MonadCatch (SubExceptT e eSub m)
forall e a.
(HasCallStack, Exception e) =>
SubExceptT e eSub m a
-> (e -> SubExceptT e eSub m a) -> SubExceptT e eSub m a
forall e eSub (m :: * -> *).
MonadCatch m =>
MonadThrow (SubExceptT e eSub m)
forall e eSub (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
SubExceptT e eSub m a
-> (e -> SubExceptT e eSub m a) -> SubExceptT e eSub m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e eSub (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
SubExceptT e eSub m a
-> (e -> SubExceptT e eSub m a) -> SubExceptT e eSub m a
catch :: forall e a.
(HasCallStack, Exception e) =>
SubExceptT e eSub m a
-> (e -> SubExceptT e eSub m a) -> SubExceptT e eSub m a
MonadCatch, MonadCatch (SubExceptT e eSub m)
MonadCatch (SubExceptT e eSub m) =>
(forall b.
 HasCallStack =>
 ((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
  -> SubExceptT e eSub m b)
 -> SubExceptT e eSub m b)
-> (forall b.
    HasCallStack =>
    ((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
     -> SubExceptT e eSub m b)
    -> SubExceptT e eSub m b)
-> (forall a b c.
    HasCallStack =>
    SubExceptT e eSub m a
    -> (a -> ExitCase b -> SubExceptT e eSub m c)
    -> (a -> SubExceptT e eSub m b)
    -> SubExceptT e eSub m (b, c))
-> MonadMask (SubExceptT e eSub m)
forall b.
HasCallStack =>
((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
forall a b c.
HasCallStack =>
SubExceptT e eSub m a
-> (a -> ExitCase b -> SubExceptT e eSub m c)
-> (a -> SubExceptT e eSub m b)
-> SubExceptT e eSub m (b, c)
forall e eSub (m :: * -> *).
MonadMask m =>
MonadCatch (SubExceptT e eSub m)
forall e eSub (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
forall e eSub (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
SubExceptT e eSub m a
-> (a -> ExitCase b -> SubExceptT e eSub m c)
-> (a -> SubExceptT e eSub m b)
-> SubExceptT e eSub m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall e eSub (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
mask :: forall b.
HasCallStack =>
((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
$cuninterruptibleMask :: forall e eSub (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
$cgeneralBracket :: forall e eSub (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
SubExceptT e eSub m a
-> (a -> ExitCase b -> SubExceptT e eSub m c)
-> (a -> SubExceptT e eSub m b)
-> SubExceptT e eSub m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
SubExceptT e eSub m a
-> (a -> ExitCase b -> SubExceptT e eSub m c)
-> (a -> SubExceptT e eSub m b)
-> SubExceptT e eSub m (b, c)
MonadMask, Monad (SubExceptT e eSub m)
Monad (SubExceptT e eSub m) =>
(forall a. IO a -> SubExceptT e eSub m a)
-> MonadIO (SubExceptT e eSub m)
forall a. IO a -> SubExceptT e eSub m a
forall e eSub (m :: * -> *).
MonadIO m =>
Monad (SubExceptT e eSub m)
forall e eSub (m :: * -> *) a.
MonadIO m =>
IO a -> SubExceptT e eSub m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall e eSub (m :: * -> *) a.
MonadIO m =>
IO a -> SubExceptT e eSub m a
liftIO :: forall a. IO a -> SubExceptT e eSub m a
MonadIO, Monad (SubExceptT e eSub m)
Monad (SubExceptT e eSub m) =>
(forall a. String -> SubExceptT e eSub m a)
-> MonadFail (SubExceptT e eSub m)
forall a. String -> SubExceptT e eSub m a
forall e eSub (m :: * -> *).
MonadFail m =>
Monad (SubExceptT e eSub m)
forall e eSub (m :: * -> *) a.
MonadFail m =>
String -> SubExceptT e eSub m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall e eSub (m :: * -> *) a.
MonadFail m =>
String -> SubExceptT e eSub m a
fail :: forall a. String -> SubExceptT e eSub m a
MonadFail)

deriving instance MonadLog o m => MonadLog o (SubExceptT e eSub m)

instance MonadTrans (SubExceptT e eSub) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> SubExceptT e eSub m a
lift = ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a
forall e eSub (m :: * -> *) a.
ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a
SubExceptT (ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a)
-> (m a -> ReaderT (WrappedPrism' e eSub) m a)
-> m a
-> SubExceptT e eSub m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (WrappedPrism' e eSub) m a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (WrappedPrism' e eSub) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadError e m => MonadError eSub (SubExceptT e eSub m) where
  throwError :: forall a. eSub -> SubExceptT e eSub m a
throwError eSub
e = ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a
forall e eSub (m :: * -> *) a.
ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a
SubExceptT (ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a)
-> ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a
forall a b. (a -> b) -> a -> b
$ do
    WrappedPrism' p <- ReaderT (WrappedPrism' e eSub) m (WrappedPrism' e eSub)
forall r (m :: * -> *). MonadReader r m => m r
ask
    throwError $ review p e
  catchError :: forall a.
SubExceptT e eSub m a
-> (eSub -> SubExceptT e eSub m a) -> SubExceptT e eSub m a
catchError SubExceptT e eSub m a
a eSub -> SubExceptT e eSub m a
h = ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a
forall e eSub (m :: * -> *) a.
ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a
SubExceptT (ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a)
-> ReaderT (WrappedPrism' e eSub) m a -> SubExceptT e eSub m a
forall a b. (a -> b) -> a -> b
$ do
    WrappedPrism' p <- ReaderT (WrappedPrism' e eSub) m (WrappedPrism' e eSub)
forall r (m :: * -> *). MonadReader r m => m r
ask
    lift $ catchError (runSubExceptT p a) $ \e
e -> case Getting (First eSub) e eSub -> e -> Maybe eSub
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First eSub) e eSub
Prism' e eSub
p e
e of
      Maybe eSub
Nothing -> e -> m a
forall a. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
      Just eSub
eSub -> Prism' e eSub -> SubExceptT e eSub m a -> m a
forall e eSub (m :: * -> *) a.
Prism' e eSub -> SubExceptT e eSub m a -> m a
runSubExceptT p eSub (f eSub) -> p e (f e)
Prism' e eSub
p (SubExceptT e eSub m a -> m a) -> SubExceptT e eSub m a -> m a
forall a b. (a -> b) -> a -> b
$ eSub -> SubExceptT e eSub m a
h eSub
eSub

runSubExceptT :: Prism' e eSub -> SubExceptT e eSub m a -> m a
runSubExceptT :: forall e eSub (m :: * -> *) a.
Prism' e eSub -> SubExceptT e eSub m a -> m a
runSubExceptT Prism' e eSub
p SubExceptT e eSub m a
a = ReaderT (WrappedPrism' e eSub) m a -> WrappedPrism' e eSub -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (SubExceptT e eSub m a -> ReaderT (WrappedPrism' e eSub) m a
forall e eSub (m :: * -> *) a.
SubExceptT e eSub m a -> ReaderT (WrappedPrism' e eSub) m a
unSubExceptT SubExceptT e eSub m a
a) (Prism' e eSub -> WrappedPrism' e eSub
forall a b. Prism' a b -> WrappedPrism' a b
WrappedPrism' p eSub (f eSub) -> p e (f e)
Prism' e eSub
p)