{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
module Dep.ReaderAdvice.Basic
(
returnMempty,
printArgs,
Simple.MethodName,
Simple.StackFrame,
Simple.SyntheticCallStack,
Simple.HasSyntheticCallStack (..),
Simple.SyntheticStackTrace,
Simple.SyntheticStackTraceException (..),
keepCallStack
)
where
import Dep.ReaderAdvice
import Control.Monad.Dep
import Data.Proxy
import Data.SOP
import Data.SOP (hctraverse_)
import Data.SOP.NP
import Data.Type.Equality
import System.IO
import Type.Reflection
import Control.Concurrent
import Control.Monad.IO.Unlift
import Control.Exception
import qualified Data.Typeable as T
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.IORef
import Dep.SimpleAdvice.Basic qualified as Simple
import Dep.SimpleAdvice.Basic (HasSyntheticCallStack)
returnMempty :: forall ca env m r. (Monad m, Monoid r) => Advice ca env m r
returnMempty :: forall (ca :: * -> Constraint) env (m :: * -> *) r.
(Monad m, Monoid r) =>
Advice ca env m r
returnMempty =
forall (ca :: * -> Constraint) e (m :: * -> *) r.
Applicative m =>
(ReaderT e m r -> ReaderT e m r) -> Advice ca e m r
makeExecutionAdvice
( \ReaderT env m r
action -> do
r
_ <- ReaderT env m r
action
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty :: r)
)
printArgs :: forall env m r. MonadIO m => Handle -> String -> Advice Show env m r
printArgs :: forall env (m :: * -> *) r.
MonadIO m =>
Handle -> String -> Advice Show env m r
printArgs Handle
h String
prefix =
forall (ca :: * -> Constraint) e (m :: * -> *) r.
Monad m =>
(forall (as :: [*]). All ca as => NP I as -> ReaderT e m (NP I as))
-> Advice ca e m r
makeArgsAdvice
( \NP I as
args -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
h forall a b. (a -> b) -> a -> b
$ String
prefix forall a. [a] -> [a] -> [a]
++ String
":"
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
(xs :: l) (g :: * -> *) (proxy :: (k -> Constraint) -> *)
(f :: k -> *).
(HTraverse_ h, AllN h c xs, Applicative g) =>
proxy c -> (forall (a :: k). c a => f a -> g ()) -> h f xs -> g ()
hctraverse_ (forall {k} (t :: k). Proxy t
Proxy @Show) (\(I a
a) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStr Handle
h (String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a))) NP I as
args
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
"\n"
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
h
forall (f :: * -> *) a. Applicative f => a -> f a
pure NP I as
args
)
keepCallStack ::
(MonadUnliftIO m, Simple.HasSyntheticCallStack env, Exception e) =>
(SomeException -> Maybe e) ->
NonEmpty (T.TypeRep, Simple.MethodName) ->
Advice ca env m r
keepCallStack :: forall (m :: * -> *) env e (ca :: * -> Constraint) r.
(MonadUnliftIO m, HasSyntheticCallStack env, Exception e) =>
(SomeException -> Maybe e)
-> NonEmpty (TypeRep, String) -> Advice ca env m r
keepCallStack SomeException -> Maybe e
selector NonEmpty (TypeRep, String)
method = forall (ca :: * -> Constraint) e (m :: * -> *) r.
Applicative m =>
(ReaderT e m r -> ReaderT e m r) -> Advice ca e m r
makeExecutionAdvice \ReaderT env m r
action -> do
SyntheticCallStack
currentStack <- forall (m :: * -> *). MonadCallStack m => m SyntheticCallStack
Simple.askCallStack
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. ReaderT env m a -> IO a
unlift -> do
Either e r
er <- forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust SomeException -> Maybe e
selector (forall a. ReaderT env m a -> IO a
unlift (forall (m :: * -> *) r.
MonadCallStack m =>
NonEmpty (TypeRep, String) -> m r -> m r
Simple.addStackFrame NonEmpty (TypeRep, String)
method ReaderT env m r
action))
case Either e r
er of
Left e
e -> forall e a. Exception e => e -> IO a
throwIO (SomeException
-> SyntheticStackTrace -> SyntheticStackTraceException
Simple.SyntheticStackTraceException (forall e. Exception e => e -> SomeException
toException e
e) (NonEmpty (TypeRep, String)
method forall a. a -> [a] -> NonEmpty a
:| SyntheticCallStack
currentStack))
Right r
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r