{-# 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 #-}

-- |
-- This module contains basic examples advices.
--
-- __/BEWARE!/__ These are provided for illustrative purposes only, they
-- strive for simplicity and not robustness or efficiency.
--
-- They can be converted to @DepT@-based 'Dep.Advice.Advice's using 'Dep.Advice.fromSimple'.
module Dep.SimpleAdvice.Basic
  ( -- * Basic advices
    returnMempty,
    printArgs,
    AnyEq (..),
    doCachingBadly,
    doAsyncBadly,
    injectFailures,
    -- ** Synthetic call stacks
    MethodName,
    StackFrame,
    SyntheticCallStack,
    HasSyntheticCallStack (..),
    SyntheticStackTrace,
    SyntheticStackTraceException (..),
    MonadCallStack (..),
    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

-- $setup
--
-- >>> :set -XTypeApplications
-- >>> :set -XStandaloneKindSignatures
-- >>> :set -XMultiParamTypeClasses
-- >>> :set -XFunctionalDependencies
-- >>> :set -XRankNTypes
-- >>> :set -XTypeOperators
-- >>> :set -XConstraintKinds
-- >>> :set -XNamedFieldPuns
-- >>> :set -XFlexibleContexts
-- >>> :set -XFlexibleInstances
-- >>> :set -XAllowAmbiguousTypes
-- >>> :set -XBlockArguments
-- >>> import Control.Monad
-- >>> import Control.Monad.Trans
-- >>> import Dep.SimpleAdvice
-- >>> import Dep.SimpleAdvice.Basic (printArgs,returnMempty)
-- >>> import Data.Kind
-- >>> import Data.SOP
-- >>> import Data.SOP.NP
-- >>> import Data.Monoid
-- >>> import System.IO
-- >>> import Data.IORef



-- | Makes functions discard their result and always return 'mempty'.
--
returnMempty :: forall ca m r. (Monad m, Monoid r) => Advice ca m r
returnMempty :: forall (ca :: * -> Constraint) (m :: * -> *) r.
(Monad m, Monoid r) =>
Advice ca m r
returnMempty =
  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
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Monoid a => a
mempty :: r)
    )

-- | Given a 'Handle' and a prefix string, makes functions print their
-- arguments to the 'Handle'.
--
printArgs :: forall m r. MonadIO m => Handle -> String -> Advice Show m r
printArgs :: forall (m :: * -> *) r.
MonadIO m =>
Handle -> String -> Advice Show m r
printArgs Handle
h String
prefix =
  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
        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
    )

-- | A helper datatype for universal equality comparisons of existentialized values, used by 'doCachingBadly'.
--
-- For a more complete elaboration of this idea, see the the \"exinst\" package.
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 forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (forall a. Typeable a => a -> TypeRep a
typeOf a
any1) (forall a. Typeable a => a -> TypeRep a
typeOf a
any2) of
      Maybe (a :~: a)
Nothing -> Bool
False
      Just a :~: a
Refl -> a
any1 forall a. Eq a => a -> a -> Bool
== a
any2

-- | 
-- Given the means for looking up and storing @r@ values in the underlying
-- monad @m@, makes functions (inefficiently) cache their results.
--
-- The monad @m@ and the result type @r@ must be known before building the
-- advice. So, once built, this 'Advice' won't be polymorphic over them.
--
-- The implementation of this function makes use of the existential type
-- parameter @u@ of 'makeAdvice', because the phase that processes the function
-- arguments needs to communicate the calculated `AnyEq` cache key to the phase
-- that processes the function result.
--
-- A better implementation of this advice would likely use an @AnyHashable@
-- helper datatype for the keys.
doCachingBadly :: forall m r. Monad m => (AnyEq -> m (Maybe r)) -> (AnyEq -> r -> m ()) -> Advice (Eq `And` Typeable) m r
doCachingBadly :: forall (m :: * -> *) r.
Monad m =>
(AnyEq -> m (Maybe r))
-> (AnyEq -> r -> m ()) -> Advice (And Eq Typeable) m r
doCachingBadly AnyEq -> m (Maybe r)
cacheLookup AnyEq -> r -> m ()
cachePut = 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 = forall a. (Typeable a, Eq a) => a -> AnyEq
AnyEq forall a b. (a -> b) -> a -> b
$ 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 (forall {k} (t :: k). Proxy t
Proxy @(And Eq Typeable)) (\(I a
a) -> [forall a. (Typeable a, Eq a) => a -> AnyEq
AnyEq a
a]) 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ AnyEq -> r -> m ()
cachePut AnyEq
key r
r
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
                  Just r
r ->
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r
         in forall (f :: * -> *) a. Applicative f => a -> f a
pure (AspectT m r -> AspectT m r
tweakExecution, NP I as
args)

-- | Makes functions that return `()` launch asynchronously.
--
-- A better implementation of this advice would likely use the \"async\"
-- package instead of bare `forkIO`. 
doAsyncBadly :: forall ca m . MonadUnliftIO m => Advice ca m ()
doAsyncBadly :: forall (ca :: * -> Constraint) (m :: * -> *).
MonadUnliftIO m =>
Advice ca m ()
doAsyncBadly = forall (ca :: * -> Constraint) (m :: * -> *) r.
Applicative m =>
(AspectT m r -> AspectT m r) -> Advice ca m r
makeExecutionAdvice \AspectT m ()
action -> do
    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 (forall a. AspectT m a -> IO a
unlift AspectT m ()
action))
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Given a reference with two infinite lists of 'IO' actions, on each
-- invocation of the advised function, take an action from the first list and
-- execute it before, and take one action from the second list and execute it
-- after.
--
-- A common use for this would be to pass exception-throwing actions.
injectFailures :: forall ca m r . (MonadIO m, MonadFail m) => IORef ([IO ()], [IO ()]) -> Advice ca m r
injectFailures :: forall (ca :: * -> Constraint) (m :: * -> *) r.
(MonadIO m, MonadFail m) =>
IORef ([IO ()], [IO ()]) -> Advice ca m r
injectFailures IORef ([IO ()], [IO ()])
ref = 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) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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))
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
before
    r
r <- AspectT m r
action
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
after
    forall (f :: * -> *) a. Applicative f => a -> f a
pure r
r


-- Synthetic call stacks
--


type MethodName = String

-- | The typeable representation of the record which contains the invoked
-- function, along with the field name of the invoked function.
type StackFrame = NonEmpty (T.TypeRep, MethodName)

type SyntheticCallStack = [StackFrame]

type SyntheticStackTrace = NonEmpty StackFrame

-- | Wraps an exception along with a 'SyntheticCallStack'.
data SyntheticStackTraceException
  = SyntheticStackTraceException SomeException SyntheticStackTrace
  deriving stock Int -> SyntheticStackTraceException -> ShowS
[SyntheticStackTraceException] -> ShowS
SyntheticStackTraceException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SyntheticStackTraceException] -> ShowS
$cshowList :: [SyntheticStackTraceException] -> ShowS
show :: SyntheticStackTraceException -> String
$cshow :: SyntheticStackTraceException -> String
showsPrec :: Int -> SyntheticStackTraceException -> ShowS
$cshowsPrec :: Int -> SyntheticStackTraceException -> ShowS
Show

instance Exception SyntheticStackTraceException

-- | Monads that carry a 'SyntheticCallStack'.
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 = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall {k} {k} a1 (b1 :: k) a2 c (b2 :: k).
((a1 -> Constant a1 b1) -> a2 -> Constant c b2) -> a2 -> c
view forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack)
  addStackFrame :: forall r.
NonEmpty (TypeRep, String)
-> ReaderT runenv m r -> ReaderT runenv m r
addStackFrame NonEmpty (TypeRep, String)
frame ReaderT runenv m r
action = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a1 a2 a3 c.
((a1 -> Identity a2) -> a3 -> Identity c) -> (a1 -> a2) -> a3 -> c
over forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack (NonEmpty (TypeRep, String)
frame 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 = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall {k} {k} a1 (b1 :: k) a2 c (b2 :: k).
((a1 -> Constant a1 b1) -> a2 -> Constant c b2) -> a2 -> c
view forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack)
  addStackFrame :: forall r. NonEmpty (TypeRep, String) -> DepT e_ m r -> DepT e_ m r
addStackFrame NonEmpty (TypeRep, String)
frame DepT e_ m r
action = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a1 a2 a3 c.
((a1 -> Identity a2) -> a3 -> Identity c) -> (a1 -> a2) -> a3 -> c
over forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack (NonEmpty (TypeRep, String)
frame forall a. a -> [a] -> [a]
:)) DepT e_ m r
action

deriving newtype instance MonadCallStack m => MonadCallStack (AspectT m)

-- | Class of environments that carry a 'SyntheticCallStack' value that can be
-- modified.
class HasSyntheticCallStack e where
    -- | A lens from the environment to the call stack.
    callStack :: forall f . Functor f => (SyntheticCallStack -> f SyntheticCallStack) -> e -> f e

-- | The trivial case, useful when 'SyntheticCallStack' is the environment type
-- of a 'Control.Monad.Reader.ReaderT'.
instance HasSyntheticCallStack SyntheticCallStack where
    callStack :: forall (f :: * -> *).
Functor f =>
(SyntheticCallStack -> f SyntheticCallStack)
-> SyntheticCallStack -> f SyntheticCallStack
callStack = forall a. a -> a
id

instance HasSyntheticCallStack s => HasSyntheticCallStack (Const s x) where
    callStack :: forall (f :: * -> *).
Functor f =>
(SyntheticCallStack -> f SyntheticCallStack)
-> Const s x -> f (Const s x)
callStack SyntheticCallStack -> f SyntheticCallStack
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack SyntheticCallStack -> f SyntheticCallStack
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). Const a b -> a
getConst

instance HasSyntheticCallStack s => HasSyntheticCallStack (Constant s x) where
    callStack :: forall (f :: * -> *).
Functor f =>
(SyntheticCallStack -> f SyntheticCallStack)
-> Constant s x -> f (Constant s x)
callStack SyntheticCallStack -> f SyntheticCallStack
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} a (b :: k). a -> Constant a b
Constant forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (f :: * -> *).
(HasSyntheticCallStack e, Functor f) =>
(SyntheticCallStack -> f SyntheticCallStack) -> e -> f e
callStack SyntheticCallStack -> f SyntheticCallStack
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} a (b :: k). Constant a b -> a
getConstant


-- | If the environment carries a 'SyntheticCallStack', make advised functions add
-- themselves to the 'SyntheticCallStack' before they start executing.
--
-- This 'Dep.SimpleAdvice.Advice' requires a reader-like base monad to work. It
-- doesn't need to be 'Control.Monad.Dep.DepT', it can be regular a
-- 'Control.Monad.Reader.ReaderT'.
--
-- Caught exceptions are rethrown wrapped in 'SyntheticStackTraceException's,
-- with the current 'SyntheticCallStack' added.
keepCallStack ::
  (MonadUnliftIO m, MonadCallStack m, Exception e) =>
  -- | A selector for the kinds of exceptions we want to catch.
  -- For example @ fromException \@IOError@.
  (SomeException -> Maybe e) ->
  -- | The path to the current component/method in the environment.
  -- It will be usually obtained through
  -- 'Dep.SimpleAdvice.adviseRecord'.
  NonEmpty (T.TypeRep, MethodName) ->
  Advice ca m r
keepCallStack :: forall (m :: * -> *) e (ca :: * -> Constraint) r.
(MonadUnliftIO m, MonadCallStack m, Exception e) =>
(SomeException -> Maybe e)
-> NonEmpty (TypeRep, String) -> Advice ca m r
keepCallStack SomeException -> Maybe e
selector NonEmpty (TypeRep, String)
method = 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 <- forall (m :: * -> *). MonadCallStack m => m SyntheticCallStack
askCallStack
  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 <- forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust SomeException -> Maybe e
selector (forall a. AspectT m a -> IO a
unlift (forall (m :: * -> *) r.
MonadCallStack m =>
NonEmpty (TypeRep, String) -> m r -> m r
addStackFrame NonEmpty (TypeRep, String)
method AspectT m r
action))
    case Either e r
er of
      Left e
e -> forall e a. Exception e => e -> IO a
throwIO (SomeException
-> SyntheticStackTrace -> SyntheticStackTraceException
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


view :: ((a1 -> Constant a1 b1) -> a2 -> Constant c b2) -> a2 -> c
view :: forall {k} {k} a1 (b1 :: k) a2 c (b2 :: k).
((a1 -> Constant a1 b1) -> a2 -> Constant c b2) -> a2 -> c
view (a1 -> Constant a1 b1) -> a2 -> Constant c b2
l = forall {k} a (b :: k). Constant a b -> a
getConstant forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a1 -> Constant a1 b1) -> a2 -> Constant c b2
l forall {k} a (b :: k). a -> Constant a b
Constant

over :: ((a1 -> Identity a2) -> a3 -> Identity c) -> (a1 -> a2) -> a3 -> c
over :: forall a1 a2 a3 c.
((a1 -> Identity a2) -> a3 -> Identity c) -> (a1 -> a2) -> a3 -> c
over (a1 -> Identity a2) -> a3 -> Identity c
l a1 -> a2
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a1 -> Identity a2) -> a3 -> Identity c
l (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. a1 -> a2
f)