dep-t-advice 0.5.1.0 → 0.6.0.0

raw patch · 10 files changed

+360/−104 lines, 10 filesdep ~dep-tPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: dep-t

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• dep-t-advice.cabal +2/−7
• lib/Control/Monad/Dep/Advice.hs +0/−7
• lib/Control/Monad/Dep/Advice/Basic.hs +0/−7
• lib/Control/Monad/Dep/SimpleAdvice.hs +0/−8
• lib/Control/Monad/Dep/SimpleAdvice/Basic.hs +0/−7
• lib/Dep/Advice.hs +55/−8
• lib/Dep/SimpleAdvice/Basic.hs +47/−16
• test/doctests.hs +4/−4
• test/synthetic-callstack-tests.hs +237/−40

@@ -1,5 +1,20 @@ # Revision history for dep-t-advice
 
+
+## 0.6.0.0 
+
+* SyntheticCallStackException renamed to SyntheticStackTraceException.
+  SyntheticStackTraceException now contains NonEmpty stack traces. 
+
+  Also, for each frame, the full path in the environment to the component is
+  provided. This is helpful for Dep.Tagged components.
+  
+  [Issue #18](https://github.com/danidiaz/dep-t-advice/issues/18).
+
+* `Dep.Advice.component` can now treat components with nested records.
+
+* Removed deprecated modules.
+
 ## 0.5.1.0 
 
 * `Control.Monad.whatever` renamed to `whatever`. 

@@ -1,7 +1,7 @@ cabal-version:       3.0
 
 name:                dep-t-advice
-version:             0.5.1.0
+version:             0.6.0.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.5.1.0 && < 0.6,
+                       dep-t ^>= 0.6,
                        mtl ^>= 2.2,
                        unliftio-core ^>= 0.2.0.0,
   default-language:    Haskell2010
@@ -58,11 +58,6 @@                        Dep.Advice.Basic
                        Dep.SimpleAdvice
                        Dep.SimpleAdvice.Basic
-                       -- deprecated
-                       Control.Monad.Dep.Advice
-                       Control.Monad.Dep.Advice.Basic
-                       Control.Monad.Dep.SimpleAdvice
-                       Control.Monad.Dep.SimpleAdvice.Basic
   other-modules:       Dep.SimpleAdvice.Internal    
                         
   hs-source-dirs:      lib 

@@ -1,7 +0,0 @@-module Control.Monad.Dep.Advice {-# DEPRECATED "Renamed to Dep.Advice" #-}
-  (
-    module Dep.Advice
-  )
-where
-
-import Dep.Advice

@@ -1,7 +0,0 @@-module Control.Monad.Dep.Advice.Basic {-# DEPRECATED "Renamed to Dep.Advice.Basic" #-}
-  ( 
-    module Dep.Advice.Basic
-  )
-where
-
-import Dep.Advice.Basic

@@ -1,8 +0,0 @@-module Control.Monad.Dep.SimpleAdvice {-# DEPRECATED "Renamed to Dep.SimpleAdvice" #-}
-  (
-    module Dep.SimpleAdvice
-  )
-where
-
-import Dep.SimpleAdvice
-

@@ -1,7 +0,0 @@-module Control.Monad.Dep.SimpleAdvice.Basic {-# DEPRECATED "Renamed to Dep.SimpleAdvice.Basic" #-}
-  (
-    module Dep.SimpleAdvice.Basic 
-  )
-where
-
-import Dep.SimpleAdvice.Basic

@@ -766,13 +766,59 @@ 
 instance
   ( 
+    Functor m,
+    DistributiveSubcomponent (DiscriminateDistributiveSubcomponent advised) e_ m advised
+  ) =>
+  DistributiveProduct e_ m (G.S1 ( 'G.MetaSel msymbol su ss ds) (G.Rec0 advised))
+  where
+  _distributeProduct f = G.M1 . G.K1 $ _distributeSubcomponent @(DiscriminateDistributiveSubcomponent advised) @e_ @m @advised (fmap (fmap (G.unK1 . G.unM1))  f)
+
+-- Here we have dropped the polymorphic parameter in the last type argument.
+type DistributiveSubcomponent :: RecordComponent -> ((Type -> Type) -> Type) -> (Type -> Type) -> Type -> Constraint
+class DistributiveSubcomponent component_type e_ m sub where
+  _distributeSubcomponent ::  (e_ (DepT e_ m) -> m sub) -> sub
+
+instance
+  ( 
     Functor m, 
     Multicurryable as e_ m r advised
   ) =>
-  DistributiveProduct e_ m (G.S1 ( 'G.MetaSel msymbol su ss ds) (G.Rec0 advised))
+  DistributiveSubcomponent Terminal e_ m advised
   where
-  _distributeProduct f = G.M1 . G.K1 $ askFinalDepT @as @e_ @m @r (fmap (fmap (G.unK1 . G.unM1))  f)
+  _distributeSubcomponent f = askFinalDepT @as @e_ @m @r f
 
+instance
+  (
+  Functor m,
+  DistributiveSubcomponent (DiscriminateDistributiveSubcomponent advised) e_ m advised 
+  ) =>
+  DistributiveSubcomponent IWrapped e_ m (Identity advised)
+  where
+  _distributeSubcomponent f = Identity (_distributeSubcomponent @(DiscriminateDistributiveSubcomponent advised) @e_ @m (fmap (fmap runIdentity) f))
+
+instance
+  (
+  Functor m,
+  DistributiveSubcomponent (DiscriminateDistributiveSubcomponent advised) e_ m advised 
+  ) =>
+  DistributiveSubcomponent IWrapped e_ m (I advised)
+  where
+  _distributeSubcomponent f = I (_distributeSubcomponent @(DiscriminateDistributiveSubcomponent advised) @e_ @m (fmap (fmap unI) f))
+
+instance
+    (DistributiveRecord e_ m subrecord)
+    =>
+    DistributiveSubcomponent Recurse e_ m (subrecord (DepT e_ m)) where
+  _distributeSubcomponent f = _distribute @e_ @m f
+
+type DiscriminateDistributiveSubcomponent :: Type -> RecordComponent
+type family DiscriminateDistributiveSubcomponent c where
+  DiscriminateDistributiveSubcomponent (a -> b) = Terminal
+  DiscriminateDistributiveSubcomponent (DepT e_ m x) = Terminal
+  DiscriminateDistributiveSubcomponent (Identity _) = IWrapped
+  DiscriminateDistributiveSubcomponent (I _) = IWrapped
+  DiscriminateDistributiveSubcomponent _ = Recurse
+
 -- advising *all* fields of a record
 --
 --
@@ -829,12 +875,6 @@      in G.M1 (G.K1 (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e_ @m @cr acc' f advised))
 
 instance
-  AdvisedRecord ca e_ m cr advisable =>
-  AdvisedComponent Recurse ca e_ m cr (advisable (DepT e_ m))
-  where
-  _adviseComponent acc f advised = _adviseRecord @ca @e_ @m @cr acc f advised
-
-instance
   (Multicurryable as e_ m r advised, All ca as, cr r, Monad m) =>
   AdvisedComponent Terminal ca e_ m cr advised
   where
@@ -851,6 +891,13 @@   AdvisedComponent IWrapped ca e_ m cr (I advised)
   where
   _adviseComponent acc f (I advised) = I (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e_ @m @cr acc f advised)
+
+instance
+  AdvisedRecord ca e_ m cr advisable =>
+  AdvisedComponent Recurse ca e_ m cr (advisable (DepT e_ m))
+  where
+  _adviseComponent acc f advised = _adviseRecord @ca @e_ @m @cr acc f advised
+
 
 -- | Gives 'Advice' to all the functions in a record-of-functions.
 --

@@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TypeApplications #-}
@@ -12,6 +13,9 @@ {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
 
 -- |
 -- This module contains basic examples advices.
@@ -32,8 +36,9 @@     MethodName,
     StackFrame,
     SyntheticCallStack,
-    SyntheticCallStackException (..),
     HasSyntheticCallStack (..),
+    SyntheticStackTrace,
+    SyntheticStackTraceException (..),
     keepCallStack
   )
 where
@@ -48,6 +53,7 @@ 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
@@ -57,6 +63,8 @@ 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
 --
@@ -182,17 +190,34 @@ 
 -- | The typeable representation of the record which contains the invoked
 -- function, along with the field name of the invoked function.
-type StackFrame = (T.TypeRep, MethodName)
+type StackFrame = NonEmpty (T.TypeRep, MethodName)
 
 type SyntheticCallStack = [StackFrame]
 
+type SyntheticStackTrace = NonEmpty StackFrame
+
 -- | Wraps an exception along with a 'SyntheticCallStack'.
-data SyntheticCallStackException
-  = SyntheticCallStackException SomeException SyntheticCallStack
+data SyntheticStackTraceException
+  = SyntheticStackTraceException SomeException SyntheticStackTrace
   deriving stock Show
 
-instance Exception SyntheticCallStackException
+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 = asks (view callStack)
+  addStackFrame frame action = local (over callStack (frame :)) action
+
+instance (Monad m, HasSyntheticCallStack (e_ (DepT e_ m))) => MonadCallStack (DepT e_ m) where
+  askCallStack = asks (view callStack)
+  addStackFrame frame action = local (over callStack (frame :)) 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
@@ -204,6 +229,10 @@ instance HasSyntheticCallStack SyntheticCallStack where
     callStack = id
 
+instance HasSyntheticCallStack s => HasSyntheticCallStack (Const s x) where
+    callStack f = fmap Const . callStack f . getConst
+
+
 -- | If the environment carries a 'SyntheticCallStack', make advised functions add
 -- themselves to the 'SyntheticCallStack' before they start executing.
 --
@@ -211,28 +240,30 @@ -- doesn't need to be 'Control.Monad.Dep.DepT', it can be regular a
 -- 'Control.Monad.Reader.ReaderT'.
 --
--- Caught exceptions are rethrown wrapped in 'SyntheticCallStackException's,
+-- Caught exceptions are rethrown wrapped in 'SyntheticStackTraceException's,
 -- with the current 'SyntheticCallStack' added.
 keepCallStack ::
-  (MonadUnliftIO m, MonadReader runenv m, HasSyntheticCallStack runenv, Exception e) =>
+  (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. Only the
-  -- head is used. It will be usually obtained through
+  -- | 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 selector (NonEmpty.head -> method) = makeExecutionAdvice \action -> do
-  currentStack <- asks (view callStack)
+keepCallStack selector method = makeExecutionAdvice \action -> do
+  currentStack <- askCallStack
   withRunInIO \unlift -> do
-    er <- tryJust selector (unlift (local (over callStack (method :)) action))
+    er <- tryJust selector (unlift (addStackFrame method action))
     case er of
-      Left e -> throwIO (SyntheticCallStackException (toException e) (method : currentStack))
+      Left e -> throwIO (SyntheticStackTraceException (toException e) (method :| currentStack))
       Right r -> pure r
-  where
-  view l = getConstant . l Constant
-  over l f = runIdentity . l (Identity . f)
 
 
+view :: ((a1 -> Constant a1 b1) -> a2 -> Constant c b2) -> a2 -> c
+view l = getConstant . l Constant
+
+over :: ((a1 -> Identity a2) -> a3 -> Identity c) -> (a1 -> a2) -> a3 -> c
+over l f = runIdentity . l (Identity . f)
 

@@ -5,8 +5,8 @@ main =
   doctest
     [ "-ilib",
-      "lib/Control/Monad/Dep/Advice.hs"
-    , "lib/Control/Monad/Dep/Advice/Basic.hs"
-    , "lib/Control/Monad/Dep/SimpleAdvice.hs"
-    , "lib/Control/Monad/Dep/SimpleAdvice/Basic.hs"
+      "lib/Dep/Advice.hs"
+    , "lib/Dep/Advice/Basic.hs"
+    , "lib/Dep/SimpleAdvice.hs"
+    , "lib/Dep/SimpleAdvice/Basic.hs"
     ]

@@ -35,6 +35,7 @@ import Control.Monad.Trans.Cont
 import Data.Function ((&))
 import Data.Functor ((<&>))
+import Control.Arrow ((>>>))
 import Data.Functor.Compose
 import Data.Functor.Constant
 import Data.Functor.Identity
@@ -62,6 +63,7 @@   ( Has (dep),
     asCall,
   )
+import Dep.Tagged (Tagged (..), tagged, untag)
 import Dep.SimpleAdvice
   ( Advice,
     AspectT (..),
@@ -70,13 +72,23 @@     advising,
     makeExecutionAdvice,
   )
-import Dep.SimpleAdvice.Basic (HasSyntheticCallStack (callStack), MethodName, StackFrame, SyntheticCallStack, SyntheticCallStackException (SyntheticCallStackException), injectFailures, keepCallStack)
+import Dep.SimpleAdvice.Basic
+  ( HasSyntheticCallStack (callStack),
+    MethodName,
+    StackFrame,
+    SyntheticCallStack,
+    SyntheticStackTrace,
+    SyntheticStackTraceException (SyntheticStackTraceException),
+    injectFailures,
+    keepCallStack,
+  )
 import GHC.Generics (Generic)
 import GHC.TypeLits
 import Lens.Micro (Lens', lens)
 import System.IO
 import Test.Tasty
 import Test.Tasty.HUnit
+import Data.Functor.Const
 import Prelude hiding (insert, lookup)
 
 -- THE BUSINESS LOGIC
@@ -143,9 +155,25 @@     { route = \toInsert toLookup -> do
         call emitMsg "serving..."
         call insert toInsert
+        call emitMsg "before lookup..."
         call lookup toLookup
     }
 
+makeController2Loggers :: 
+  (Has Logger m env, 
+  Has (Tagged "secondary" Logger) m env, Has Repository m env, Monad m) =>
+  env ->
+  Controller m
+makeController2Loggers (asCall -> call) =
+  Controller
+    { route = \toInsert toLookup -> do
+        call (untag @"secondary" >>> emitMsg) "serving..."
+        call insert toInsert
+        call emitMsg "before lookup..."
+        call lookup toLookup
+    }
+
+
 -- THE COMPOSITION ROOT
 --
 -- Here we define our dependency injection environment.
@@ -159,6 +187,7 @@ -- "Higer-Kinded Data" pattern.)
 data Env h m = Env
   { logger :: h (Logger m),
+    logger2 :: h (Tagged "secondary" Logger m),
     repository :: h (Repository m),
     controller :: h (Controller m)
   }
@@ -185,7 +214,7 @@ --
 -- There could be more phases, like for example an initial "read configuration"
 -- phase.
-type Phases env_ m = Allocator `Compose` Constructor env_ m
+type Phases env = Allocator `Compose` Constructor env
 
 -- Environment value
 --
@@ -194,30 +223,41 @@ --
 -- Notice that neither the interfaces nor the implementations which we defined
 -- earlier knew anything about the ReaderT.
-env :: Env (Phases Env (ReaderT SyntheticCallStack IO)) (ReaderT SyntheticCallStack IO)
+env :: Env (Phases (Env Identity (ReaderT SyntheticCallStack IO))) (ReaderT SyntheticCallStack IO)
 env =
   Env
     { logger =
         allocateBombs 1 `bindPhase` \bombs ->
-          constructor (\_ -> makeStdoutLogger)
-            <&> advising
-              ( adviseRecord @Top @Top \method ->
-                  keepCallStack ioEx method <> injectFailures bombs
-              ),
+          constructor \_ ->
+            makeStdoutLogger
+              & advising
+                ( adviseRecord @Top @Top \method ->
+                    keepCallStack ioEx method <> injectFailures bombs
+                ),
+      logger2 =
+        allocateBombs 0 `bindPhase` \bombs ->
+          constructor \_ ->
+            tagged @"secondary" makeStdoutLogger
+              & advising
+                ( adviseRecord @Top @Top \method ->
+                    keepCallStack ioEx method <> injectFailures bombs
+                ),
       repository =
         allocateSet `bindPhase` \ref ->
-          constructor (makeInMemoryRepository ref)
-            <&> advising
-              ( adviseRecord @Top @Top \method ->
-                  keepCallStack ioEx method
-              ),
+          constructor \env ->
+            makeInMemoryRepository ref env
+              & advising
+                ( adviseRecord @Top @Top \method ->
+                    keepCallStack ioEx method
+                ),
       controller =
         skipPhase @Allocator $
-          constructor makeController
-            <&> advising
-              ( adviseRecord @Top @Top \method ->
-                  keepCallStack ioEx method
-              )
+          constructor \env ->
+            makeController env
+              & advising
+                ( adviseRecord @Top @Top \method ->
+                    keepCallStack ioEx method
+                )
     }
 
 -- Catch only IOExceptions for this example.
@@ -274,43 +314,105 @@   Env
     { logger =
         allocateBombs 1 `bindPhase` \bombs ->
-          Identity (A.component \_ -> makeStdoutLogger)
-            <&> ( A.adviseRecord @Top @Top \method ->
-                    A.fromSimple_ (keepCallStack ioEx method <> injectFailures bombs)
-                ),
+          Identity $ A.component \_ ->
+            makeStdoutLogger
+              & A.adviseRecord @Top @Top \method ->
+                A.fromSimple_ (keepCallStack ioEx method <> 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),
       repository =
         allocateSet `bindPhase` \ref ->
-          Identity (A.component (makeInMemoryRepository ref))
-            <&> ( A.adviseRecord @Top @Top \method ->
-                    A.fromSimple_ (keepCallStack ioEx method)
-                ),
+          Identity $ A.component \env ->
+            makeInMemoryRepository ref env
+              & A.adviseRecord @Top @Top \method ->
+                A.fromSimple_ (keepCallStack ioEx method),
       controller =
         skipPhase @Allocator $
-          Identity (A.component makeController)
-            <&> ( A.adviseRecord @Top @Top \method ->
-                    A.fromSimple_ (keepCallStack ioEx method)
-                )
+          Identity $ A.component \env ->
+            makeController env
+              & A.adviseRecord @Top @Top \method ->
+                A.fromSimple_ (keepCallStack ioEx method)
     }
 
+
+-- THE COMPOSITION ROOT - YET ANOTER APPROACH
+--
+-- 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
+-- behave almost as a regular ReaderT.
+-- 
+-- What are the benefits of unsing DepT instead of ReaderT here? Basically
+-- being able to use runFinalDepT in the test, which feels somewhat cleaner than
+-- runReaderT.
+type RT e m = DepT (Const e) m
+
+env'' :: Env (Phases (Env Identity (RT SyntheticCallStack IO))) (RT SyntheticCallStack IO)
+env'' = 
+  Env
+    { logger =
+        allocateBombs 1 `bindPhase` \bombs ->
+          constructor \_ ->
+            makeStdoutLogger
+              & A.adviseRecord @Top @Top \method ->
+                A.fromSimple_ (keepCallStack ioEx method <> injectFailures bombs),
+      logger2 =
+        allocateBombs 0 `bindPhase` \bombs ->
+           constructor \_ ->
+            tagged @"secondary" makeStdoutLogger
+              & A.adviseRecord @Top @Top \method ->
+                A.fromSimple_ (keepCallStack ioEx method <> injectFailures bombs),
+      repository =
+        allocateSet `bindPhase` \ref ->
+          constructor \env ->
+            makeInMemoryRepository ref env
+              & A.adviseRecord @Top @Top \method ->
+                A.fromSimple_ (keepCallStack ioEx method),
+      controller =
+        skipPhase @Allocator $
+          constructor \env ->
+            makeController env
+              & A.adviseRecord @Top @Top \method ->
+                A.fromSimple_ (keepCallStack ioEx method)
+    }
+
 -- TESTS
 --
 --
-expectedException :: (IOError, SyntheticCallStack)
+expectedException :: (IOError, SyntheticStackTrace)
 expectedException =
   ( userError "oops",
-    [ (typeRep (Proxy @Logger), "emitMsg"),
-      (typeRep (Proxy @Repository), "insert"),
-      (typeRep (Proxy @Controller), "route")
+    NonEmpty.fromList
+    [ NonEmpty.fromList [(typeRep (Proxy @Logger), "emitMsg")],
+      NonEmpty.fromList [(typeRep (Proxy @Repository), "insert")],
+      NonEmpty.fromList [(typeRep (Proxy @Controller), "route")]
     ]
   )
 
+expectedExceptionTagged :: (IOError, SyntheticStackTrace)
+expectedExceptionTagged =
+  ( userError "oops",
+    NonEmpty.fromList
+    [ NonEmpty.fromList [
+                (typeRep (Proxy @Logger), "emitMsg")
+        ,       (typeRep (Proxy @(Tagged "secondary" Logger)), "unTagged")
+        ],
+      NonEmpty.fromList [(typeRep (Proxy @Controller), "route")]
+    ]
+  )
+
 -- Test the "Constructor"-based version of the environment.
 testSyntheticCallStack :: Assertion
 testSyntheticCallStack = do
   let action =
         runContT (pullPhase @Allocator env) \constructors -> do
           -- here we complete the construction of the environment
-          let (asCall -> call) = fixEnv constructors 
+          let (asCall -> call) = fixEnv constructors
           flip
             runReaderT
             ([] :: SyntheticCallStack) -- the initial stack trace for the call
@@ -318,12 +420,43 @@                 _ <- call route 1 2
                 pure ()
             )
-  me <- try @SyntheticCallStackException action
+  me <- try @SyntheticStackTraceException action
   case me of
-    Left (SyntheticCallStackException (fromException @IOError -> Just ex) trace) ->
+    Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) ->
       assertEqual "exception with callstack" expectedException (ex, trace)
     Right _ -> assertFailure "expected exception did not appear"
 
+-- Test the "Constructor"-based version of the environment.
+testSyntheticCallStackTagged :: Assertion
+testSyntheticCallStackTagged = do
+  let envz = env {
+          controller =
+            skipPhase @Allocator $
+              constructor \env ->
+                makeController2Loggers env
+                  & advising
+                    ( adviseRecord @Top @Top \method ->
+                        keepCallStack ioEx method
+                    )
+        }
+      action =
+        runContT (pullPhase @Allocator envz) \constructors -> do
+          -- here we complete the construction of the environment
+          let (asCall -> call) = fixEnv constructors
+          flip
+            runReaderT
+            ([] :: SyntheticCallStack) -- the initial stack trace for the call
+            ( do
+                _ <- call route 1 2
+                pure ()
+            )
+  me <- try @SyntheticStackTraceException action
+  case me of
+    Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) ->
+      assertEqual "exception with callstack" expectedExceptionTagged (ex, trace)
+    Right _ -> assertFailure "expected exception did not appear"
+
+
 -- Test the "DepT"-based version of the environment.
 testSyntheticCallStack' :: Assertion
 testSyntheticCallStack' = do
@@ -331,18 +464,82 @@         runContT (pullPhase @Allocator env') \runnable -> do
           _ <- A.runFromDep (pure (CallEnv [] runnable)) route 1 2
           pure ()
-  me <- try @SyntheticCallStackException action
+  me <- try @SyntheticStackTraceException action
   case me of
-    Left (SyntheticCallStackException (fromException @IOError -> Just ex) trace) ->
+    Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) ->
       assertEqual "exception with callstack" expectedException (ex, trace)
     Right _ -> assertFailure "expected exception did not appear"
 
+testSyntheticCallStackTagged' :: Assertion
+testSyntheticCallStackTagged' = do
+  let envz = env' {
+          controller =
+            skipPhase @Allocator $
+              Identity $ A.component \env ->
+                makeController2Loggers env
+                  & A.adviseRecord @Top @Top \method ->
+                    A.fromSimple_ (keepCallStack ioEx method)
+        }
+      action =
+        runContT (pullPhase @Allocator envz) \runnable -> do
+          _ <- A.runFromDep (pure (CallEnv [] runnable)) route 1 2
+          pure ()
+  me <- try @SyntheticStackTraceException action
+  case me of
+    Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) ->
+      assertEqual "exception with callstack" expectedExceptionTagged (ex, trace)
+    Right _ -> assertFailure "expected exception did not appear"
+
+
+
+testSyntheticCallStack'' :: Assertion
+testSyntheticCallStack'' = do
+  let action =
+        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
+          pure ()
+  me <- try @SyntheticStackTraceException action
+  case me of
+    Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) ->
+      assertEqual "exception with callstack" expectedException (ex, trace)
+    Right _ -> assertFailure "expected exception did not appear"
+
+
+-- Test the "Constructor"-based version of the environment.
+testSyntheticCallStackTagged'' :: Assertion
+testSyntheticCallStackTagged'' = do
+  let envz = env'' {
+          controller =
+            skipPhase @Allocator $
+              constructor \env ->
+                makeController2Loggers env
+                  & A.adviseRecord @Top @Top \method ->
+                    A.fromSimple_ (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
+          pure ()
+  me <- try @SyntheticStackTraceException action
+  case me of
+    Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) ->
+      assertEqual "exception with callstack" expectedExceptionTagged (ex, trace)
+    Right _ -> assertFailure "expected exception did not appear"
+
 tests :: TestTree
 tests =
   testGroup
     "All"
     [ testCase "synthetic call stack" testSyntheticCallStack,
-      testCase "synthetic call stack - DepT" testSyntheticCallStack'
+      testCase "synthetic call stack with Tagged" testSyntheticCallStackTagged,
+      testCase "synthetic call stack - DepT" testSyntheticCallStack',
+      testCase "synthetic call stack with Tagged - DepT" testSyntheticCallStackTagged',
+      testCase "synthetic call stack - constructor + DepT" testSyntheticCallStack'',
+      testCase "synthetic call stack with Tagged - constructor + DepT" testSyntheticCallStackTagged''
     ]
 
 main :: IO ()