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

import Control.Lens (Prism', preview, review)
import Control.Monad.Error.Class (MonadError (..))
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader
import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)
import Control.Monad.Log
import Control.Monad.Fail

-- | Wrap a Prism' in a newtype to avoid impredicativity problems
newtype WrappedPrism' a b = WrappedPrism' { WrappedPrism' a b
-> forall (p :: * -> * -> *) (f :: * -> *).
   (Choice p, Applicative f) =>
   p b (f b) -> p a (f a)
unWrappedPrism' :: Prism' a b }

newtype SubExceptT e eSub m a = SubExceptT { SubExceptT e eSub m a -> ReaderT (WrappedPrism' e eSub) m a
unSubExceptT :: ReaderT (WrappedPrism' e eSub) m a }
  deriving (a -> SubExceptT e eSub m b -> SubExceptT e eSub m a
(a -> b) -> SubExceptT e eSub m a -> SubExceptT e eSub m b
(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
<$ :: a -> SubExceptT e eSub m b -> SubExceptT e eSub m a
$c<$ :: forall e eSub (m :: * -> *) a b.
Functor m =>
a -> SubExceptT e eSub m b -> SubExceptT e eSub m a
fmap :: (a -> b) -> SubExceptT e eSub m a -> SubExceptT e eSub m b
$cfmap :: forall e eSub (m :: * -> *) a b.
Functor m =>
(a -> b) -> SubExceptT e eSub m a -> SubExceptT e eSub m b
Functor, Functor (SubExceptT e eSub m)
a -> SubExceptT e eSub m a
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)
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m a
SubExceptT e eSub m (a -> b)
-> SubExceptT e eSub m a -> SubExceptT e eSub m b
(a -> b -> c)
-> SubExceptT e eSub m a
-> SubExceptT e eSub m b
-> SubExceptT e eSub m c
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
<* :: SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m a
$c<* :: forall e eSub (m :: * -> *) a b.
Applicative m =>
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m a
*> :: 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 b
liftA2 :: (a -> b -> c)
-> SubExceptT e eSub m a
-> SubExceptT e eSub m b
-> SubExceptT e eSub m c
$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
<*> :: SubExceptT e eSub m (a -> b)
-> SubExceptT e eSub m a -> SubExceptT e eSub m b
$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
pure :: a -> SubExceptT e eSub m a
$cpure :: forall e eSub (m :: * -> *) a.
Applicative m =>
a -> SubExceptT e eSub m a
$cp1Applicative :: forall e eSub (m :: * -> *).
Applicative m =>
Functor (SubExceptT e eSub m)
Applicative, Applicative (SubExceptT e eSub m)
a -> SubExceptT e eSub m a
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)
SubExceptT e eSub m a
-> (a -> SubExceptT e eSub m b) -> SubExceptT e eSub m b
SubExceptT e eSub m a
-> SubExceptT e eSub m b -> SubExceptT e eSub m b
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
return :: a -> SubExceptT e eSub m a
$creturn :: forall e eSub (m :: * -> *) a.
Monad m =>
a -> SubExceptT e eSub m a
>> :: SubExceptT e eSub m 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
>>= :: 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
-> (a -> SubExceptT e eSub m b) -> SubExceptT e eSub m b
$cp1Monad :: forall e eSub (m :: * -> *).
Monad m =>
Applicative (SubExceptT e eSub m)
Monad, Monad (SubExceptT e eSub m)
e -> SubExceptT e eSub m a
Monad (SubExceptT e eSub m) =>
(forall e a. Exception e => e -> SubExceptT e eSub m a)
-> MonadThrow (SubExceptT e eSub m)
forall e a. 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, Exception e) =>
e -> SubExceptT e eSub m a
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> SubExceptT e eSub m a
$cthrowM :: forall e eSub (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> SubExceptT e eSub m a
$cp1MonadThrow :: forall e eSub (m :: * -> *).
MonadThrow m =>
Monad (SubExceptT e eSub m)
MonadThrow, MonadThrow (SubExceptT e eSub m)
MonadThrow (SubExceptT e eSub m) =>
(forall e a.
 Exception e =>
 SubExceptT e eSub m a
 -> (e -> SubExceptT e eSub m a) -> SubExceptT e eSub m a)
-> MonadCatch (SubExceptT e eSub m)
SubExceptT e eSub m a
-> (e -> SubExceptT e eSub m a) -> SubExceptT e eSub m a
forall e a.
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, 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. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: SubExceptT e eSub m a
-> (e -> SubExceptT e eSub m a) -> SubExceptT e eSub m a
$ccatch :: forall e eSub (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
SubExceptT e eSub m a
-> (e -> SubExceptT e eSub m a) -> SubExceptT e eSub m a
$cp1MonadCatch :: forall e eSub (m :: * -> *).
MonadCatch m =>
MonadThrow (SubExceptT e eSub m)
MonadCatch, MonadCatch (SubExceptT e eSub m)
MonadCatch (SubExceptT e eSub m) =>
(forall b.
 ((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
  -> SubExceptT e eSub m b)
 -> SubExceptT e eSub m b)
-> (forall b.
    ((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.
    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)
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 a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
forall b.
((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.
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 =>
((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 =>
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. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: 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)
$cgeneralBracket :: forall e eSub (m :: * -> *) a b c.
MonadMask m =>
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)
uninterruptibleMask :: ((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 =>
((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
mask :: ((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
$cmask :: forall e eSub (m :: * -> *) b.
MonadMask m =>
((forall a. SubExceptT e eSub m a -> SubExceptT e eSub m a)
 -> SubExceptT e eSub m b)
-> SubExceptT e eSub m b
$cp1MonadMask :: forall e eSub (m :: * -> *).
MonadMask m =>
MonadCatch (SubExceptT e eSub m)
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)
IO a -> SubExceptT e eSub m a
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
liftIO :: IO a -> SubExceptT e eSub m a
$cliftIO :: forall e eSub (m :: * -> *) a.
MonadIO m =>
IO a -> SubExceptT e eSub m a
$cp1MonadIO :: forall e eSub (m :: * -> *).
MonadIO m =>
Monad (SubExceptT e eSub m)
MonadIO, Monad (SubExceptT e eSub m)
Monad (SubExceptT e eSub m) =>
(forall a. String -> SubExceptT e eSub m a)
-> MonadFail (SubExceptT e eSub m)
String -> SubExceptT e eSub m a
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
fail :: String -> SubExceptT e eSub m a
$cfail :: forall e eSub (m :: * -> *) a.
MonadFail m =>
String -> SubExceptT e eSub m a
$cp1MonadFail :: forall e eSub (m :: * -> *).
MonadFail m =>
Monad (SubExceptT e eSub m)
MonadFail)

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

instance MonadTrans (SubExceptT e eSub) where
  lift :: 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 (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 :: eSub -> SubExceptT e eSub m a
throwError e :: 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 :: Prism' e eSub
p <- ReaderT (WrappedPrism' e eSub) m (WrappedPrism' e eSub)
forall r (m :: * -> *). MonadReader r m => m r
ask
    e -> ReaderT (WrappedPrism' e eSub) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e -> ReaderT (WrappedPrism' e eSub) m a)
-> e -> ReaderT (WrappedPrism' e eSub) m a
forall a b. (a -> b) -> a -> b
$ AReview e eSub -> eSub -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e eSub
Prism' e eSub
p eSub
e
  catchError :: SubExceptT e eSub m a
-> (eSub -> SubExceptT e eSub m a) -> SubExceptT e eSub m a
catchError a :: SubExceptT e eSub m a
a h :: 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 :: Prism' e eSub
p <- ReaderT (WrappedPrism' e eSub) m (WrappedPrism' e eSub)
forall r (m :: * -> *). MonadReader r m => m r
ask
    m a -> ReaderT (WrappedPrism' e eSub) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT (WrappedPrism' e eSub) m a)
-> m a -> ReaderT (WrappedPrism' e eSub) m a
forall a b. (a -> b) -> a -> b
$ m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (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 Prism' e eSub
p SubExceptT e eSub m a
a) ((e -> m a) -> m a) -> (e -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \e :: 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
      Nothing -> e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
      Just eSub :: 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 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 :: Prism' e eSub -> SubExceptT e eSub m a -> m a
runSubExceptT p :: Prism' e eSub
p a :: 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' Prism' e eSub
p)