{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
module Dep.SimpleAdvice.Basic
(
returnMempty,
printArgs,
AnyEq (..),
doCachingBadly,
doAsyncBadly,
injectFailures,
MethodName,
StackFrame,
SyntheticCallStack,
HasSyntheticCallStack (..),
SyntheticStackTrace,
SyntheticStackTraceException (..),
keepCallStack
)
where
import Dep.SimpleAdvice
import Control.Monad.Reader
import Control.Monad.Trans
import Data.Proxy
import Data.Functor.Constant
import Data.Functor.Identity
import Data.SOP
import Data.SOP (hctraverse_)
import Data.SOP.NP
import Data.Type.Equality
import Data.Coerce
import System.IO
import Control.Concurrent
import Control.Monad.IO.Unlift
import Data.IORef
import Control.Exception
import Type.Reflection
import qualified Data.Typeable as T
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Control.Monad.Dep (DepT)
import Data.Functor.Const
returnMempty :: forall ca m r. (Monad m, Monoid r) => Advice ca m r
returnMempty :: Advice ca m r
returnMempty =
(AspectT m r -> AspectT m r) -> Advice ca m r
forall (ca :: * -> Constraint) (m :: * -> *) r.
Applicative m =>
(AspectT m r -> AspectT m r) -> Advice ca m r
makeExecutionAdvice
( \AspectT m r
action -> do
r
_ <- AspectT m r
action
r -> AspectT m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r
forall a. Monoid a => a
mempty :: r)
)
printArgs :: forall m r. MonadIO m => Handle -> String -> Advice Show m r
printArgs :: Handle -> String -> Advice Show m r
printArgs Handle
h String
prefix =
(forall (as :: [*]). All Show as => NP I as -> AspectT m (NP I as))
-> Advice Show m r
forall (ca :: * -> Constraint) (m :: * -> *) r.
Monad m =>
(forall (as :: [*]). All ca as => NP I as -> AspectT m (NP I as))
-> Advice ca m r
makeArgsAdvice
( \NP I as
args -> do
IO () -> AspectT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AspectT m ()) -> IO () -> AspectT m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
Proxy Show
-> (forall a. Show a => I a -> AspectT m ())
-> NP I as
-> AspectT m ()
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_ (Proxy Show
forall k (t :: k). Proxy t
Proxy @Show) (\(I a) -> IO () -> AspectT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> String -> IO ()
hPutStr Handle
h (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a))) NP I as
args
IO () -> AspectT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AspectT m ()) -> IO () -> AspectT m ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
h String
"\n"
IO () -> AspectT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> AspectT m ()) -> IO () -> AspectT m ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hFlush Handle
h
NP I as -> AspectT m (NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NP I as
args
)
data AnyEq where
AnyEq :: forall a. (Typeable a, Eq a) => a -> AnyEq
instance Eq AnyEq where
AnyEq a
any1 == :: AnyEq -> AnyEq -> Bool
== AnyEq a
any2 =
case TypeRep a -> TypeRep a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (a -> TypeRep a
forall a. Typeable a => a -> TypeRep a
typeOf a
any1) (a -> TypeRep a
forall a. Typeable a => a -> TypeRep a
typeOf a
any2) of
Maybe (a :~: a)
Nothing -> Bool
False
Just a :~: a
Refl -> a
any1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a
any2
doCachingBadly :: forall m r. Monad m => (AnyEq -> m (Maybe r)) -> (AnyEq -> r -> m ()) -> Advice (Eq `And` Typeable) m r
doCachingBadly :: (AnyEq -> m (Maybe r))
-> (AnyEq -> r -> m ()) -> Advice (And Eq Typeable) m r
doCachingBadly AnyEq -> m (Maybe r)
cacheLookup AnyEq -> r -> m ()
cachePut = (forall (as :: [*]).
All (And Eq Typeable) as =>
NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice (And Eq Typeable) m r
forall (ca :: * -> Constraint) (m :: * -> *) r.
(forall (as :: [*]).
All ca as =>
NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as))
-> Advice ca m r
makeAdvice \NP I as
args ->
let key :: AnyEq
key = [AnyEq] -> AnyEq
forall a. (Typeable a, Eq a) => a -> AnyEq
AnyEq ([AnyEq] -> AnyEq) -> [AnyEq] -> AnyEq
forall a b. (a -> b) -> a -> b
$ Proxy (And Eq Typeable)
-> (forall a. And Eq Typeable a => I a -> [AnyEq])
-> NP I as
-> [AnyEq]
forall k (c :: k -> Constraint) (xs :: [k]) m
(proxy :: (k -> Constraint) -> *) (f :: k -> *).
(All c xs, Monoid m) =>
proxy c -> (forall (a :: k). c a => f a -> m) -> NP f xs -> m
cfoldMap_NP (Proxy (And Eq Typeable)
forall k (t :: k). Proxy t
Proxy @(And Eq Typeable)) (\(I a) -> [a -> AnyEq
forall a. (Typeable a, Eq a) => a -> AnyEq
AnyEq a
a]) (NP I as -> [AnyEq]) -> NP I as -> [AnyEq]
forall a b. (a -> b) -> a -> b
$ NP I as
args
tweakExecution :: AspectT m r -> AspectT m r
tweakExecution AspectT m r
action = do
Maybe r
mr <- m (Maybe r) -> AspectT m (Maybe r)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe r) -> AspectT m (Maybe r))
-> m (Maybe r) -> AspectT m (Maybe r)
forall a b. (a -> b) -> a -> b
$ AnyEq -> m (Maybe r)
cacheLookup AnyEq
key
case Maybe r
mr of
Maybe r
Nothing -> do
r
r <- AspectT m r
action
m () -> AspectT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> AspectT m ()) -> m () -> AspectT m ()
forall a b. (a -> b) -> a -> b
$ AnyEq -> r -> m ()
cachePut AnyEq
key r
r
r -> AspectT m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
Just r
r ->
r -> AspectT m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
in (AspectT m r -> AspectT m r, NP I as)
-> AspectT m (AspectT m r -> AspectT m r, NP I as)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AspectT m r -> AspectT m r
tweakExecution, NP I as
args)
doAsyncBadly :: forall ca m . MonadUnliftIO m => Advice ca m ()
doAsyncBadly :: Advice ca m ()
doAsyncBadly = (AspectT m () -> AspectT m ()) -> Advice ca m ()
forall (ca :: * -> Constraint) (m :: * -> *) r.
Applicative m =>
(AspectT m r -> AspectT m r) -> Advice ca m r
makeExecutionAdvice \AspectT m ()
action -> do
ThreadId
_ <- ((forall a. AspectT m a -> IO a) -> IO ThreadId)
-> AspectT m ThreadId
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (\forall a. AspectT m a -> IO a
unlift -> IO () -> IO ThreadId
forkIO (AspectT m () -> IO ()
forall a. AspectT m a -> IO a
unlift AspectT m ()
action))
() -> AspectT m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
injectFailures :: forall ca m r . (MonadIO m, MonadFail m) => IORef ([IO ()], [IO ()]) -> Advice ca m r
injectFailures :: IORef ([IO ()], [IO ()]) -> Advice ca m r
injectFailures IORef ([IO ()], [IO ()])
ref = (AspectT m r -> AspectT m r) -> Advice ca m r
forall (ca :: * -> Constraint) (m :: * -> *) r.
Applicative m =>
(AspectT m r -> AspectT m r) -> Advice ca m r
makeExecutionAdvice \AspectT m r
action -> do
(IO ()
before, IO ()
after) <- IO (IO (), IO ()) -> AspectT m (IO (), IO ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO (), IO ()) -> AspectT m (IO (), IO ()))
-> IO (IO (), IO ()) -> AspectT m (IO (), IO ())
forall a b. (a -> b) -> a -> b
$ IORef ([IO ()], [IO ()])
-> (([IO ()], [IO ()]) -> (([IO ()], [IO ()]), (IO (), IO ())))
-> IO (IO (), IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef ([IO ()], [IO ()])
ref \(IO ()
before : [IO ()]
befores, IO ()
after : [IO ()]
afters) -> (([IO ()]
befores, [IO ()]
afters), (IO ()
before, IO ()
after))
IO () -> AspectT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
before
r
r <- AspectT m r
action
IO () -> AspectT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
after
r -> AspectT m r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
type MethodName = String
type StackFrame = NonEmpty (T.TypeRep, MethodName)
type SyntheticCallStack = [StackFrame]
type SyntheticStackTrace = NonEmpty StackFrame
data SyntheticStackTraceException
= SyntheticStackTraceException SomeException SyntheticStackTrace
deriving stock Int -> SyntheticStackTraceException -> String -> String
[SyntheticStackTraceException] -> String -> String
SyntheticStackTraceException -> String
(Int -> SyntheticStackTraceException -> String -> String)
-> (SyntheticStackTraceException -> String)
-> ([SyntheticStackTraceException] -> String -> String)
-> Show SyntheticStackTraceException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SyntheticStackTraceException] -> String -> String
$cshowList :: [SyntheticStackTraceException] -> String -> String
show :: SyntheticStackTraceException -> String
$cshow :: SyntheticStackTraceException -> String
showsPrec :: Int -> SyntheticStackTraceException -> String -> String
$cshowsPrec :: Int -> SyntheticStackTraceException -> String -> String
Show
instance Exception SyntheticStackTraceException
class MonadCallStack m where
askCallStack :: m SyntheticCallStack
addStackFrame :: StackFrame -> m r -> m r
instance (Monad m, HasSyntheticCallStack runenv) => MonadCallStack (ReaderT runenv m) where
askCallStack :: ReaderT runenv m SyntheticCallStack
askCallStack = (runenv -> SyntheticCallStack)
-> ReaderT runenv m SyntheticCallStack
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (((SyntheticCallStack
-> Constant SyntheticCallStack SyntheticCallStack)
-> runenv -> Constant SyntheticCallStack runenv)
-> runenv -> SyntheticCallStack
forall k k a1 (b1 :: k) a2 c (b2 :: k).
((a1 -> Constant a1 b1) -> a2 -> Constant c b2) -> a2 -> c
view (SyntheticCallStack
-> Constant SyntheticCallStack SyntheticCallStack)
-> runenv -> Constant SyntheticCallStack runenv
forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack)
addStackFrame :: StackFrame -> ReaderT runenv m r -> ReaderT runenv m r
addStackFrame StackFrame
frame ReaderT runenv m r
action = (runenv -> runenv) -> ReaderT runenv m r -> ReaderT runenv m r
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (((SyntheticCallStack -> Identity SyntheticCallStack)
-> runenv -> Identity runenv)
-> (SyntheticCallStack -> SyntheticCallStack) -> runenv -> runenv
forall a1 a2 a3 c.
((a1 -> Identity a2) -> a3 -> Identity c) -> (a1 -> a2) -> a3 -> c
over (SyntheticCallStack -> Identity SyntheticCallStack)
-> runenv -> Identity runenv
forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack (StackFrame
frame StackFrame -> SyntheticCallStack -> SyntheticCallStack
forall a. a -> [a] -> [a]
:)) ReaderT runenv m r
action
instance (Monad m, HasSyntheticCallStack (e_ (DepT e_ m))) => MonadCallStack (DepT e_ m) where
askCallStack :: DepT e_ m SyntheticCallStack
askCallStack = (e_ (DepT e_ m) -> SyntheticCallStack)
-> DepT e_ m SyntheticCallStack
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (((SyntheticCallStack
-> Constant SyntheticCallStack SyntheticCallStack)
-> e_ (DepT e_ m) -> Constant SyntheticCallStack (e_ (DepT e_ m)))
-> e_ (DepT e_ m) -> SyntheticCallStack
forall k k a1 (b1 :: k) a2 c (b2 :: k).
((a1 -> Constant a1 b1) -> a2 -> Constant c b2) -> a2 -> c
view (SyntheticCallStack
-> Constant SyntheticCallStack SyntheticCallStack)
-> e_ (DepT e_ m) -> Constant SyntheticCallStack (e_ (DepT e_ m))
forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack)
addStackFrame :: StackFrame -> DepT e_ m r -> DepT e_ m r
addStackFrame StackFrame
frame DepT e_ m r
action = (e_ (DepT e_ m) -> e_ (DepT e_ m)) -> DepT e_ m r -> DepT e_ m r
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (((SyntheticCallStack -> Identity SyntheticCallStack)
-> e_ (DepT e_ m) -> Identity (e_ (DepT e_ m)))
-> (SyntheticCallStack -> SyntheticCallStack)
-> e_ (DepT e_ m)
-> e_ (DepT e_ m)
forall a1 a2 a3 c.
((a1 -> Identity a2) -> a3 -> Identity c) -> (a1 -> a2) -> a3 -> c
over (SyntheticCallStack -> Identity SyntheticCallStack)
-> e_ (DepT e_ m) -> Identity (e_ (DepT e_ m))
forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack (StackFrame
frame StackFrame -> SyntheticCallStack -> SyntheticCallStack
forall a. a -> [a] -> [a]
:)) DepT e_ m r
action
deriving newtype instance MonadCallStack m => MonadCallStack (AspectT m)
class HasSyntheticCallStack e where
callStack :: forall f . Functor f => (SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
instance HasSyntheticCallStack SyntheticCallStack where
callStack :: (SyntheticCallStack -> f SyntheticCallStack)
-> SyntheticCallStack -> f SyntheticCallStack
callStack = (SyntheticCallStack -> f SyntheticCallStack)
-> SyntheticCallStack -> f SyntheticCallStack
forall a. a -> a
id
instance HasSyntheticCallStack s => HasSyntheticCallStack (Const s x) where
callStack :: (SyntheticCallStack -> f SyntheticCallStack)
-> Const s x -> f (Const s x)
callStack SyntheticCallStack -> f SyntheticCallStack
f = (s -> Const s x) -> f s -> f (Const s x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> Const s x
forall k a (b :: k). a -> Const a b
Const (f s -> f (Const s x))
-> (Const s x -> f s) -> Const s x -> f (Const s x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SyntheticCallStack -> f SyntheticCallStack) -> s -> f s
forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack SyntheticCallStack -> f SyntheticCallStack
f (s -> f s) -> (Const s x -> s) -> Const s x -> f s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const s x -> s
forall a k (b :: k). Const a b -> a
getConst
keepCallStack ::
(MonadUnliftIO m, MonadCallStack m, Exception e) =>
(SomeException -> Maybe e) ->
NonEmpty (T.TypeRep, MethodName) ->
Advice ca m r
keepCallStack :: (SomeException -> Maybe e) -> StackFrame -> Advice ca m r
keepCallStack SomeException -> Maybe e
selector StackFrame
method = (AspectT m r -> AspectT m r) -> Advice ca m r
forall (ca :: * -> Constraint) (m :: * -> *) r.
Applicative m =>
(AspectT m r -> AspectT m r) -> Advice ca m r
makeExecutionAdvice \AspectT m r
action -> do
SyntheticCallStack
currentStack <- AspectT m SyntheticCallStack
forall (m :: * -> *). MonadCallStack m => m SyntheticCallStack
askCallStack
((forall a. AspectT m a -> IO a) -> IO r) -> AspectT m r
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. AspectT m a -> IO a
unlift -> do
Either e r
er <- (SomeException -> Maybe e) -> IO r -> IO (Either e r)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust SomeException -> Maybe e
selector (AspectT m r -> IO r
forall a. AspectT m a -> IO a
unlift (StackFrame -> AspectT m r -> AspectT m r
forall (m :: * -> *) r.
MonadCallStack m =>
StackFrame -> m r -> m r
addStackFrame StackFrame
method AspectT m r
action))
case Either e r
er of
Left e
e -> SyntheticStackTraceException -> IO r
forall e a. Exception e => e -> IO a
throwIO (SomeException
-> SyntheticStackTrace -> SyntheticStackTraceException
SyntheticStackTraceException (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e) (StackFrame
method StackFrame -> SyntheticCallStack -> SyntheticStackTrace
forall a. a -> [a] -> NonEmpty a
:| SyntheticCallStack
currentStack))
Right r
r -> r -> IO r
forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
view :: ((a1 -> Constant a1 b1) -> a2 -> Constant c b2) -> a2 -> c
view :: ((a1 -> Constant a1 b1) -> a2 -> Constant c b2) -> a2 -> c
view (a1 -> Constant a1 b1) -> a2 -> Constant c b2
l = Constant c b2 -> c
forall a k (b :: k). Constant a b -> a
getConstant (Constant c b2 -> c) -> (a2 -> Constant c b2) -> a2 -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a1 -> Constant a1 b1) -> a2 -> Constant c b2
l a1 -> Constant a1 b1
forall k a (b :: k). a -> Constant a b
Constant
over :: ((a1 -> Identity a2) -> a3 -> Identity c) -> (a1 -> a2) -> a3 -> c
over :: ((a1 -> Identity a2) -> a3 -> Identity c) -> (a1 -> a2) -> a3 -> c
over (a1 -> Identity a2) -> a3 -> Identity c
l a1 -> a2
f = Identity c -> c
forall a. Identity a -> a
runIdentity (Identity c -> c) -> (a3 -> Identity c) -> a3 -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a1 -> Identity a2) -> a3 -> Identity c
l (a2 -> Identity a2
forall a. a -> Identity a
Identity (a2 -> Identity a2) -> (a1 -> a2) -> a1 -> Identity a2
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a1 -> a2
f)