App.hs

{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}


module Shajra.App where


import           Protolude

import           Control.Lens.Getter         (view)
import           Control.Lens.Lens           (Lens')
import           Control.Lens.Setter         (over)
import           Control.Lens.TH             (makeWrapped)
import           Control.Lens.Wrapped        (_Wrapped)
import           Control.Monad.Base
    (MonadBase (liftBase), liftBaseDefault)
import           Control.Monad.Except        (withExceptT)
import           Control.Monad.Trans.Class   (MonadTrans)
import           Control.Monad.Trans.Control
    (ComposeSt, MonadBaseControl (liftBaseWith, restoreM),
    MonadTransControl (liftWith, restoreT), StM, StT, defaultLiftBaseWith,
    defaultRestoreM)
import           Control.Monad.Trans.Except  (ExceptT (ExceptT))
import           Control.Monad.Trans.Reader  (ReaderT (ReaderT))
import           Data.Void                   (Void, absurd)
import           Katip
    (Katip (getLogEnv), KatipContext (getKatipContext, getKatipNamespace),
    LogContexts, LogEnv, Namespace)


newtype App r e m a =
    App { unApp :: ExceptT e (ReaderT r m) a } deriving
        ( Functor
        , Applicative
        , Monad
        , MonadIO
        , MonadReader r
        , MonadError e )


class HasKatip r where
    katipEnv :: Lens' r LogEnv

class HasKatip r => HasKatipContext r where
    katipContexts :: Lens' r LogContexts
    katipNamespace :: Lens' r Namespace


makeWrapped ''App


instance MonadTrans (App r e) where
    lift = App . lift . lift

instance MonadBase b m => MonadBase b (App r e m) where
    liftBase = liftBaseDefault

instance MonadTransControl (App r e) where
    type StT (App r e) a = Either e a
    liftWith f =
        App . ExceptT . map pure . ReaderT $ \r ->
            f $ \t -> (runReaderT . runExceptT . unApp) t r
    restoreT = App . ExceptT . ReaderT . const

instance MonadBaseControl b m => MonadBaseControl b (App r e m) where
    type StM (App r e m) a = ComposeSt (App r e) m a
    liftBaseWith = defaultLiftBaseWith
    restoreM = defaultRestoreM

instance (MonadIO m, HasKatip r) => Katip (App r e m) where
    getLogEnv = view katipEnv

instance (MonadIO m, HasKatipContext r) => KatipContext (App r e m) where
    getKatipContext = view katipContexts
    getKatipNamespace = view katipNamespace

instance HasKatip LogEnv where
    katipEnv = identity


eitherApp :: m (Either e a) -> App r e m a
eitherApp = App . ExceptT . ReaderT . const

runApp :: Functor m => App r Void m a -> r -> m a
runApp =
    runReaderT . map (either absurd identity) . runExceptT . unApp

runUnhandledApp :: App r e m a -> r -> m (Either e a)
runUnhandledApp = runReaderT . runExceptT . unApp

handleApp
    :: Monad m => (e -> App r e' m a) -> App r e m a -> App r e' m a
handleApp h = handleAppEither $ either h pure

handleAppEither
    :: Monad m => (Either e a -> App r e' m b) -> App r e m a -> App r e' m b
handleAppEither h =
    App . ExceptT . (>>= (runExceptT . unApp . h)) . runExceptT . unApp

appWithExcept :: Functor m => (e -> e') -> App r e m a -> App r e' m a
appWithExcept h = over _Wrapped $ withExceptT h

appMapExceptF
    :: Functor m => (Either e a -> Either e' b) -> App r e m a -> App r e' m b
appMapExceptF h = appMapExcept (map h)

appMapExceptM
    :: Monad m
    => (Either e a -> m (Either e' b)) -> App r e m a -> App r e' m b
appMapExceptM h = appMapExcept (>>= h)

appMapExcept
    :: (m (Either e a) -> n (Either e' b)) -> App r e m a -> App r e' n b
appMapExcept h =
    App . ExceptT . ReaderT . map h . runReaderT . runExceptT . unApp

Error.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE NoImplicitPrelude         #-}
{-# LANGUAGE ScopedTypeVariables       #-}


module Shajra.Error where


import           Protolude                   hiding
    (bracket, bracketOnError, bracket_, catch, catchJust, catches, finally,
    handle, handleJust, onException, throwIO, throwTo, try, tryJust)

import           Control.Concurrent          (ThreadId)
import qualified Control.Exception.Safe      as E
import           Control.Lens.Review         (AReview)
import           Control.Monad.Base          (MonadBase, liftBase)
import           Control.Monad.Error.Lens    (throwing)
import           Control.Monad.Except        (catchError)
import           Control.Monad.Trans.Control
    (MonadBaseControl, StM, control, liftBaseWith, restoreM)
import           System.IO.Error             as E (IOError, ioError)


data Handler m a = forall e. Exception e => Handler (e -> m a)

data MonadErrorException = MonadErrorException deriving (Show, Typeable)
instance Exception MonadErrorException

data MonadErrorException' e = MonadErrorException' e deriving (Show, Typeable)
instance (Show e, Typeable e) => Exception (MonadErrorException' e)


onError :: (MonadError e m, MonadBaseControl IO m) => m a -> m b -> m b
onError after thing = bracketOnError (pure ()) (const after) (const thing)
{-# INLINABLE onError #-}

onError'
    ::  ( Show e
        , Typeable e
        , E.MonadMask m'
        , MonadError e m
        , MonadBaseControl m' m)
    => m a -> m b -> m b
onError' after thing = bracketOnError' (pure ()) (const after) (const thing)

bracketOnError
    :: (MonadError e m, MonadBaseControl IO m)
    => m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError before after thing =
    liftBase newEmptyMVar >>= \v -> handle (handler v) $ bracketing v
    where
    bracketing var = bracketOnException before after (stowError var . thing)
    stowError var =
        flip catchError $ \e ->
            liftBase $ putMVar var e *> E.throw MonadErrorException
    handler var MonadErrorException = liftBase (takeMVar var) >>= throwError
{-# INLINABLE bracketOnError #-}

bracketOnError'
    ::  ( Show e
        , Typeable e
        , E.MonadMask m'
        , MonadError e m
        , MonadBaseControl m' m)
    => m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError' before after thing =
    handle handler $ bracketing
    where
    bracketing = bracketOnException before after $ exceptError . thing
    exceptError = flip catchError $ throw . MonadErrorException'
    handler (MonadErrorException' e) = throwError e
{-# INLINABLE bracketOnError' #-}

toError
    :: forall t e m m' a .
        (Exception t, E.MonadCatch m', MonadError e m, MonadBaseControl m' m)
    => (t -> e) -> m a -> m a
toError f ma =
    control $ \run ->
        E.handle (run . (throwError . f :: t -> m a)) $ run ma
{-# INLINABLE toError #-}

reviewError
    :: forall t e m m' e' a .
        (Exception t, E.MonadCatch m', MonadError e m, MonadBaseControl m' m)
    => (t -> e') -> AReview e e' -> m a -> m a
reviewError f r ma =
    control $ \run ->
        E.handle (run . (throwing r . f :: t -> m a)) $ run ma
{-# INLINABLE reviewError #-}

throw :: (E.MonadThrow m', MonadBase m' m, Exception e) => e -> m a
throw = liftBase . E.throw
{-# INLINABLE throw #-}

ioError :: MonadBase IO m => IOError -> m a
ioError = liftBase . E.ioError
{-# INLINABLE ioError #-}

throwTo :: (MonadIO m', MonadBase m' m, Exception e) => ThreadId -> e -> m ()
throwTo tid e = liftBase $ E.throwTo tid e
{-# INLINABLE throwTo #-}

catch
    :: (E.MonadCatch m', MonadBaseControl m' m, Exception e)
    => m a -> (e -> m a) -> m a
catch a handler =
    control $ \run -> E.catch (run a) (\e -> run $ handler e)
{-# INLINABLE catch #-}

catches
    :: (E.MonadCatch m', MonadBaseControl m' m) => m a -> [Handler m a] -> m a
catches a handlers =
    control $ \run ->
        E.catches (run a)
            [ E.Handler $ \e -> run $ handler e
            | Handler handler <- handlers
            ]
{-# INLINABLE catches #-}

catchJust
    :: (E.MonadCatch m', MonadBaseControl m' m, Exception e)
    => (e -> Maybe b) -> m a -> (b -> m a) -> m a
catchJust p a handler =
    control $ \run -> E.catchJust p (run a) (\e -> run (handler e))
{-# INLINABLE catchJust #-}

handle
    :: (E.MonadCatch m', MonadBaseControl m' m, Exception e)
    => (e -> m a) -> m a -> m a
handle handler a =
    control $ \run -> E.handle (\e -> run (handler e)) (run a)
{-# INLINABLE handle #-}

handleJust
    :: (E.MonadCatch m', MonadBaseControl m' m, Exception e)
    => (e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust p handler a =
    control $ \run ->
        E.handleJust p (\e -> run (handler e)) (run a)
{-# INLINABLE handleJust #-}

sequenceEither :: MonadBaseControl m' m => Either e (StM m a) -> m (Either e a)
sequenceEither = either (return . Left) (liftM Right . restoreM)
{-# INLINE sequenceEither #-}

try :: (E.MonadCatch m', MonadBaseControl m' m, Exception e)
    => m a -> m (Either e a)
try m = liftBaseWith (\run -> E.try (run m)) >>= sequenceEither
{-# INLINABLE try #-}

tryJust
    :: (E.MonadCatch m', MonadBaseControl m' m, Exception e)
    => (e -> Maybe b) -> m a -> m (Either b a)
tryJust p m =
    liftBaseWith (\run -> E.tryJust p (run m)) >>= sequenceEither
{-# INLINABLE tryJust #-}

bracket
    :: (E.MonadMask m', MonadBaseControl m' m)
    => m a -> (a -> m b) -> (a -> m c) -> m c
bracket before after thing =
    control $ \run ->
        E.bracket (run before)
            (\st -> run $ restoreM st >>= after)
            (\st -> run $ restoreM st >>= thing)
{-# INLINABLE bracket #-}

bracket_ :: (E.MonadMask m', MonadBaseControl m' m) => m a -> m b -> m c -> m c
bracket_ before after thing = bracket before (const after) (const thing)
{-# INLINABLE bracket_ #-}

bracketOnException
    :: (E.MonadMask m', MonadBaseControl m' m)
    => m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnException before after thing =
    control $ \run ->
        E.bracketOnError (run before)
            (\st -> run $ restoreM st >>= after)
            (\st -> run $ restoreM st >>= thing)
{-# INLINABLE bracketOnException #-}

finally :: (E.MonadMask m', MonadBaseControl m' m) => m a -> m b -> m a
finally a sequel = control $ \run -> E.finally (run a) (run sequel)
{-# INLINABLE finally #-}

onException :: E.MonadMask m' => MonadBaseControl m' m => m a -> m b -> m a
onException m what =
    control $ \run -> E.onException (run m) (run what)
{-# INLINABLE onException #-}