dep-t-advice 0.6.0.0 → 0.6.1.0

raw patch · 6 files changed

+124/−26 lines, 6 filesdep ~dep-tdep ~mtldep ~transformersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: dep-t, mtl, transformers, unliftio-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• dep-t-advice.cabal +2/−2
• lib/Dep/Advice/Basic.hs +88/−1
• lib/Dep/SimpleAdvice/Basic.hs +5/−1
• test/synthetic-callstack-tests.hs +21/−19
• test/tests.hs +3/−3

@@ -1,5 +1,10 @@ # Revision history for dep-t-advice
 
+## 0.6.1.0 
+
+* Export `MonadCallStack` https://github.com/danidiaz/dep-t-advice/issues/23
+
+* Export converted versions of `Dep.SimpleAdvice.Basic` from `Dep.Advice.Basic`.
 
 ## 0.6.0.0 
 

@@ -1,7 +1,7 @@ cabal-version:       3.0
 
 name:                dep-t-advice
-version:             0.6.0.0
+version:             0.6.1.0
 synopsis:            Giving good advice to functions in records-of-functions.
 description:         
                      Companion to the dep-t package. Easily add behaviour to
@@ -30,7 +30,7 @@   build-depends:       base >=4.10.0.0 && < 5,
                        sop-core ^>= 0.5.0.0,
                        transformers ^>= 0.5.0.0,
-                       dep-t ^>= 0.6,
+                       dep-t >= 0.6.1 && < 0.7,
                        mtl ^>= 2.2,
                        unliftio-core ^>= 0.2.0.0,
   default-language:    Haskell2010

@@ -8,6 +8,7 @@ {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 
 -- |
@@ -17,11 +18,27 @@ -- strive for simplicity and not robustness or efficiency.
 module Dep.Advice.Basic
   ( -- * Basic advices
-    doLocally
+    returnMempty,
+    printArgs,
+    SA.AnyEq (..),
+    doCachingBadly,
+    doAsyncBadly,
+    injectFailures,
+    doLocally,
+    -- ** Synthetic call stacks
+    SA.MethodName,
+    SA.StackFrame,
+    SA.SyntheticCallStack,
+    SA.HasSyntheticCallStack (..),
+    SA.SyntheticStackTrace,
+    SA.SyntheticStackTraceException (..),
+    SA.MonadCallStack (..),
+    keepCallStack
   )
 where
 
 import Dep.Advice
+import qualified Dep.SimpleAdvice.Basic as SA 
 import Control.Monad.Dep
 import Data.Proxy
 import Data.SOP
@@ -31,6 +48,13 @@ 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 qualified Dep.SimpleAdvice.Basic as SA
+import Data.IORef
 
 -- $setup
 --
@@ -105,4 +129,67 @@ doLocally :: forall ca e_ m r. Monad m => (e_ (DepT e_ m) -> e_ (DepT e_ m)) -> Advice ca e_ m r 
 doLocally transform = makeExecutionAdvice (local transform)  
 
+-- | Makes functions discard their result and always return 'mempty'.
+--
+returnMempty :: forall ca e_ m r. (Monad m, Monoid r) => Advice ca e_ m r
+returnMempty = fromSimple_ SA.returnMempty
 
+-- | Given a 'Handle' and a prefix string, makes functions print their
+-- arguments to the 'Handle'.
+--
+printArgs :: forall e_ m r. (Monad m, MonadIO (DepT e_ m)) => Handle -> String -> Advice Show e_ m r
+printArgs h prefix = fromSimple_ (SA.printArgs h prefix)
+
+-- | 
+-- 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 e_ m r. Monad m => (SA.AnyEq -> DepT e_ m (Maybe r)) -> (SA.AnyEq -> r -> DepT e_ m ()) -> Advice (Eq `And` Typeable) e_ m r
+doCachingBadly cacheLookup cachePut = fromSimple_ (SA.doCachingBadly cacheLookup cachePut)
+
+-- | 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 e_ m . (Monad m, MonadUnliftIO (DepT e_ m)) => Advice ca e_ m ()
+doAsyncBadly = fromSimple_ SA.doAsyncBadly
+
+-- | 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 e_ m r . (Monad m, MonadIO (DepT e_ m), MonadFail (DepT e_ m)) => IORef ([IO ()], [IO ()]) -> Advice ca e_ m r
+injectFailures ref = fromSimple_ (SA.injectFailures ref)
+
+-- | 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 ::
+  (Monad m, MonadUnliftIO (DepT e_ m), SA.MonadCallStack (DepT e_ 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, SA.MethodName) ->
+  Advice ca e_ m r
+keepCallStack selector method = fromSimple_ (SA.keepCallStack selector method)

@@ -39,6 +39,7 @@     HasSyntheticCallStack (..),
     SyntheticStackTrace,
     SyntheticStackTraceException (..),
+    MonadCallStack (..),
     keepCallStack
   )
 where
@@ -203,7 +204,7 @@ 
 instance Exception SyntheticStackTraceException
 
--- | Monads that carry a SyntheticCallStack.
+-- | Monads that carry a 'SyntheticCallStack'.
 class MonadCallStack m where
   askCallStack :: m SyntheticCallStack
   addStackFrame :: StackFrame -> m r -> m r
@@ -231,6 +232,9 @@ 
 instance HasSyntheticCallStack s => HasSyntheticCallStack (Const s x) where
     callStack f = fmap Const . callStack f . getConst
+
+instance HasSyntheticCallStack s => HasSyntheticCallStack (Constant s x) where
+    callStack f = fmap Constant . callStack f . getConstant
 
 
 -- | If the environment carries a 'SyntheticCallStack', make advised functions add

@@ -22,7 +22,7 @@ 
 -- | An example of how an application can make use of the "dep-t" and
 -- "dep-t-advice" packages for keeping a "synthetic" call stack that tracks the
--- invocations of monadic functions—though only of those which take part in dependency
+-- invocations of monadic functions-though only of those which take part in dependency
 -- injection.
 --
 -- We are assuming that the application follows a "record-of-functions" style.
@@ -46,6 +46,8 @@ import Data.Set qualified as Set
 import Data.Typeable
 import Dep.Advice qualified as A
+import Dep.Advice.Basic qualified as A
+import Dep.Has
 import Dep.Env
   ( Autowireable,
     Autowired (..),
@@ -159,9 +161,9 @@         call lookup toLookup
     }
 
+type MakeController2LoggersDeps = '[Logger, Tagged "secondary" Logger, Repository]
 makeController2Loggers :: 
-  (Has Logger m env, 
-  Has (Tagged "secondary" Logger) m env, Has Repository m env, Monad m) =>
+  (HasAll MakeController2LoggersDeps m env, Monad m) =>
   env ->
   Controller m
 makeController2Loggers (asCall -> call) =
@@ -304,7 +306,7 @@ 
 -- Here use the DepT monad (a variant of ReaderT) as the base monad.
 --
--- The environment of DepT includes—just as before—the SyntheticCallStack value
+-- The environment of DepT includes-just as before-the SyntheticCallStack value
 -- that is used to trace each sub-call.
 --
 -- But now it also includes the dependency injection context with all the
@@ -317,25 +319,25 @@           Identity $ A.component \_ ->
             makeStdoutLogger
               & A.adviseRecord @Top @Top \method ->
-                A.fromSimple_ (keepCallStack ioEx method <> injectFailures bombs),
+                A.keepCallStack ioEx method <> A.injectFailures bombs,
       logger2 =
         allocateBombs 0 `bindPhase` \bombs ->
           Identity $ A.component \_ ->
             tagged @"secondary" makeStdoutLogger
               & A.adviseRecord @Top @Top \method ->
-                A.fromSimple_ (keepCallStack ioEx method <> injectFailures bombs),
+                A.keepCallStack ioEx method <> A.injectFailures bombs,
       repository =
         allocateSet `bindPhase` \ref ->
           Identity $ A.component \env ->
             makeInMemoryRepository ref env
               & A.adviseRecord @Top @Top \method ->
-                A.fromSimple_ (keepCallStack ioEx method),
+                A.keepCallStack ioEx method,
       controller =
         skipPhase @Allocator $
           Identity $ A.component \env ->
             makeController env
               & A.adviseRecord @Top @Top \method ->
-                A.fromSimple_ (keepCallStack ioEx method)
+                A.keepCallStack ioEx method
     }
 
 
@@ -344,13 +346,13 @@ -- This approach also uses DepT, but not to carry the dependencies, only to carry 
 -- the call stack (like ReaderT in the first approach). 
 --
--- This is done by parameterizing DepT with Const, which makes DepT
+-- This is done by parameterizing DepT with Constant, which makes DepT
 -- behave almost as a regular ReaderT.
 -- 
--- What are the benefits of unsing DepT instead of ReaderT here? Basically
+-- What are the benefits of unsing DepT instead of ReaderT here? Well, basically
 -- being able to use runFinalDepT in the test, which feels somewhat cleaner than
 -- runReaderT.
-type RT e m = DepT (Const e) m
+type RT e m = DepT (Constant e) m
 
 env'' :: Env (Phases (Env Identity (RT SyntheticCallStack IO))) (RT SyntheticCallStack IO)
 env'' = 
@@ -360,25 +362,25 @@           constructor \_ ->
             makeStdoutLogger
               & A.adviseRecord @Top @Top \method ->
-                A.fromSimple_ (keepCallStack ioEx method <> injectFailures bombs),
+                A.keepCallStack ioEx method <> A.injectFailures bombs,
       logger2 =
         allocateBombs 0 `bindPhase` \bombs ->
            constructor \_ ->
             tagged @"secondary" makeStdoutLogger
               & A.adviseRecord @Top @Top \method ->
-                A.fromSimple_ (keepCallStack ioEx method <> injectFailures bombs),
+                A.keepCallStack ioEx method <> A.injectFailures bombs,
       repository =
         allocateSet `bindPhase` \ref ->
           constructor \env ->
             makeInMemoryRepository ref env
               & A.adviseRecord @Top @Top \method ->
-                A.fromSimple_ (keepCallStack ioEx method),
+                A.keepCallStack ioEx method,
       controller =
         skipPhase @Allocator $
           constructor \env ->
             makeController env
               & A.adviseRecord @Top @Top \method ->
-                A.fromSimple_ (keepCallStack ioEx method)
+                A.keepCallStack ioEx method
     }
 
 -- TESTS
@@ -478,7 +480,7 @@               Identity $ A.component \env ->
                 makeController2Loggers env
                   & A.adviseRecord @Top @Top \method ->
-                    A.fromSimple_ (keepCallStack ioEx method)
+                    A.keepCallStack ioEx method
         }
       action =
         runContT (pullPhase @Allocator envz) \runnable -> do
@@ -498,7 +500,7 @@         runContT (pullPhase @Allocator env'') \constructors -> do
           -- here we complete the construction of the environment
           let (asCall -> call) = fixEnv constructors
-          A.runFinalDepT (pure (Const [])) (call route) 1 2
+          A.runFinalDepT (pure (Constant [])) (call route) 1 2
           pure ()
   me <- try @SyntheticStackTraceException action
   case me of
@@ -516,13 +518,13 @@               constructor \env ->
                 makeController2Loggers env
                   & A.adviseRecord @Top @Top \method ->
-                    A.fromSimple_ (keepCallStack ioEx method)
+                    A.keepCallStack ioEx method
         }
       action =
         runContT (pullPhase @Allocator envz) \constructors -> do
           -- here we complete the construction of the environment
           let (asCall -> call) = fixEnv constructors
-          A.runFinalDepT (pure (Const [])) (call route) 1 2
+          A.runFinalDepT (pure (Constant [])) (call route) 1 2
           pure ()
   me <- try @SyntheticStackTraceException action
   case me of

@@ -19,7 +19,7 @@ module Main (main) where
 
 import Dep.Advice
-import Dep.Advice.Basic
+import qualified Dep.Advice.Basic as A
 import Dep.SimpleAdvice.Basic
 import Control.Monad.Dep
 import Control.Monad.Reader
@@ -227,7 +227,7 @@ weirdAdvicedEnv :: Env (DepT Env (Writer TestTrace))
 weirdAdvicedEnv =
    env {
-         _controller = advise (doLogging <> fromSimple \_ -> returnMempty) (_controller env), --,
+         _controller = advise (doLogging <> A.returnMempty) (_controller env), --,
          -- This advice below doesn't really do anything, I'm just experimenting with passing the constraints with type application
          _logger = advise @(Show `And` Eq) (makeAdvice (\args -> pure (id, args))) (_logger env)
        }
@@ -262,7 +262,7 @@ returnMempty'' = fromSimple (\_ -> returnMempty) <> justAResultConstraint
 
 printArgs' :: Advice (Eq `And` Ord `And` Show) e_ IO ()
-printArgs' = restrictArgs @(Eq `And` Ord `And` Show) (\Dict -> Dict) (fromSimple \_ -> printArgs stdout "foo")
+printArgs' = restrictArgs @(Eq `And` Ord `And` Show) (\Dict -> Dict) (A.printArgs stdout "foo")
  
 -- does EnvConstraint compile?