dep-t-advice 0.3.0.0 → 0.4.0.0

raw patch · 7 files changed

+342/−150 lines, 7 filesdep +criteriondep ~dep-tPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion

Dependency ranges changed: dep-t

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +4/−4
• benchmark/benchmarks.hs +72/−0
• dep-t-advice.cabal +14/−2
• lib/Control/Monad/Dep/Advice.hs +191/−99
• lib/Control/Monad/Dep/Advice/Basic.hs +20/−13
• test/tests.hs +33/−32

@@ -1,5 +1,13 @@ # Revision history for dep-t-advice
 
+## 0.4.0.0 
+
+* Added 'deceive' function.
+
+* BREAKING CHANGE. The form of the 'HasX' constraints expected by 'Ensure' has
+  changed. Now they expect the effect monad as their first parameter. This is
+  in order to help with deriving.
+
 ## 0.3.0.0 
 
 * BREAKING CHANGE. Removed the dependency on "constraints" to reduce the

@@ -35,18 +35,18 @@ 
 Imagine that you want to make this function print its argument to stdout:
 
-    foo :: Int -> DepT e IO () 
+    foo :: Int -> DepT e_ IO () 
 
 Easy enough:
 
-    foo' :: Int -> DepT e IO ()
+    foo' :: Int -> DepT e_ IO ()
     foo' arg1 = do
         liftIO $ putStrLn (show arg1)
         foo arg1
 
 You can even write your own general "printArgs" combinator:
 
-    printArgs :: Show a => (a -> DepT e IO ()) -> (a -> DepT e IO ())
+    printArgs :: Show a => (a -> DepT e_ IO ()) -> (a -> DepT e_ IO ())
     printArgs f arg1 = do
         liftIO $ putStrLn (show arg1)
         f arg1
@@ -82,7 +82,7 @@ 
 Here's how a `printArgs` advice might be defined:
 
-    printArgs :: forall e m r. MonadIO m => Handle -> String -> Advice Show e m r
+    printArgs :: forall e_ m r. MonadIO m => Handle -> String -> Advice Show e_ m r
     printArgs h prefix =
       makeArgsAdvice
         ( \args -> do

@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module Main where
+
+import Criterion.Main
+
+import Control.Monad.Dep
+import Control.Monad.Dep.Advice
+import Control.Monad.Dep.Advice.Basic
+import Data.Monoid
+import Data.Functor.Identity
+import Data.Foldable
+
+-- returnMempty' :: forall ca e m r. (Monad m, Monoid r) => Advice ca e m r
+-- returnMempty' =
+--   makeAdvice @()
+--     (\args -> pure (pure args))
+--     ( \() action -> do
+--         _ <- action
+--         pure (mempty :: r)
+--     )
+
+mempty' :: forall ca e m r. Monad m => Advice ca e m r
+mempty' = makeAdvice @()
+  (\args -> pure (pure args))
+  (\() -> id)
+
+summy :: Monad m => Int -> Int -> Int -> Int -> DepT NilEnv m (Sum Int)
+summy a1 a2 a3 a4 = pure $ Sum a1 <> Sum a2 <> Sum a3 <> Sum a4
+
+summyInstrumented :: Monad m => Int -> Int -> Int -> Int -> DepT NilEnv m (Sum Int)
+summyInstrumented = 
+    advise @Top mempty summy
+
+summyInstrumented' :: Monad m => Int -> Int -> Int -> Int -> DepT NilEnv m (Sum Int)
+summyInstrumented' = 
+    advise @Top mempty' summy
+
+main :: IO ()
+main =
+  defaultMain
+    [ bgroup
+        "adviceOverhead"
+        [ 
+            bench "not instrumented" $ 
+                whnf 
+                (foldl' (+) 0 . take 100000 . map (\(a1, a2, a3, a4) -> runIdentity $ summy a1 a2 a3 a4 `runDepT` NilEnv))
+                (repeat (0,0,0,0)),
+            bench "instrumented id advice" $ 
+                whnf 
+                (foldl' (+) 0 . take 100000 . map (\(a1, a2, a3, a4) -> runIdentity $ summyInstrumented a1 a2 a3 a4 `runDepT` NilEnv)) 
+                (repeat (0,0,0,0)),
+            bench "instrumented locally defined id advice" $ 
+                whnf 
+                (foldl' (+) 0 . take 100000 . map (\(a1, a2, a3, a4) -> runIdentity $ summyInstrumented' a1 a2 a3 a4 `runDepT` NilEnv)) 
+                (repeat (0,0,0,0))
+        ]
+    ] 
+

@@ -1,7 +1,7 @@ cabal-version:       3.0
 
 name:                dep-t-advice
-version:             0.3.0.0
+version:             0.4.0.0
 synopsis:            Giving good advice to functions in a DepT environment.
 description:         Companion to the dep-t package. Easily add behaviour to functions living in a DepT environment, 
                      whatever the number of arguments they might have.
@@ -23,7 +23,8 @@ common common
   build-depends:       base >=4.10.0.0 && < 5,
                        sop-core ^>= 0.5.0.0,
-                       dep-t ^>= 0.1.3.0,
+                       transformers ^>= 0.5.0.0,
+                       dep-t ^>= 0.4.0.0,
   default-language:    Haskell2010
 
 common common-tests
@@ -70,3 +71,14 @@   build-depends:       
                        doctest            ^>= 0.17 
                        
+ -- https://cabal.readthedocs.io/en/3.4/cabal-package.html#benchmarks
+benchmark benchmark
+  import:              common-tests, 
+  type:                exitcode-stdio-1.0
+  ghc-options:         -O2
+  hs-source-dirs:      benchmark
+  main-is:             benchmarks.hs
+  build-depends:
+                       criterion ^>= 1.5,  
+
+

@@ -93,6 +93,9 @@     runFinalDepT,
     runFromEnv,
 
+    -- * Making functions see a different environment
+    deceive,
+
     -- * "sop-core" re-exports
     -- $sop
     Top,
@@ -101,11 +104,12 @@     NP (..),
     I (..),
     cfoldMap_NP,
-    Dict (..)
+    Dict (..),
   )
 where
 
 import Control.Monad.Dep
+import Control.Monad.Trans.Reader (ReaderT(..),withReaderT)
 import Data.Kind
 import Data.SOP
 import Data.SOP.Dict
@@ -122,10 +126,15 @@ -- >>> :set -XConstraintKinds
 -- >>> :set -XNamedFieldPuns
 -- >>> :set -XFlexibleContexts
+-- >>> :set -XDerivingStrategies
+-- >>> :set -XGeneralizedNewtypeDeriving
+-- >>> :set -XDataKinds
+-- >>> :set -XScopedTypeVariables
 -- >>> import Control.Monad
 -- >>> import Control.Monad.Dep
 -- >>> import Control.Monad.Dep.Advice
 -- >>> import Control.Monad.Dep.Advice.Basic (printArgs,returnMempty)
+-- >>> import Control.Monad.Writer
 -- >>> import Data.Kind
 -- >>> import Data.SOP
 -- >>> import Data.SOP.NP
@@ -134,11 +143,11 @@ -- >>> import Data.IORef
 
 -- | A generic transformation of 'DepT'-effectful functions with environment
--- @e@ of kind @(Type -> Type) -> Type@, base monad @m@ and return type @r@,
+-- @e_@ of kind @(Type -> Type) -> Type@, base monad @m@ and return type @r@,
 -- provided the functions satisfy certain constraint @ca@ of kind @Type ->
 -- Constraint@ on all of their arguments.
 --
--- Note that the type constructor for the environment @e@ is given unapplied.
+-- Note that the type constructor for the environment @e_@ is given unapplied.
 -- That is, @Advice Show NilEnv IO ()@ kind-checks but @Advice Show (NilEnv IO)
 -- IO ()@ doesn't. See also 'Ensure'.
 --
@@ -154,55 +163,52 @@   (Type -> Type) ->
   Type ->
   Type
-data Advice ca e m r where
+data Advice ca e_ m r where
   Advice ::
-    forall u ca e m r.
+    forall u ca e_ m r.
     Proxy u ->
     ( forall as.
       All ca as =>
       NP I as ->
-      DepT e m (u, NP I as)
+      DepT e_ m (u, NP I as)
     ) ->
-    ( 
-      u ->
-      DepT e m r ->
-      DepT e m r
+    ( u ->
+      DepT e_ m r ->
+      DepT e_ m r
     ) ->
-    Advice ca e m r
+    Advice ca e_ m r
 
 -- |
---    Aspects compose \"sequentially\" when tweaking the arguments, and
+--    'Advice's compose \"sequentially\" when tweaking the arguments, and
 --    \"concentrically\" when tweaking the final 'DepT' action.
 --
 --    The first 'Advice' is the \"outer\" one. It tweaks the function arguments
 --    first, and wraps around the execution of the second, \"inner\" 'Advice'.
-instance Monad m => Semigroup (Advice ca e m r) where
+instance Monad m => Semigroup (Advice ca e_ m r) where
   Advice outer tweakArgsOuter tweakExecutionOuter <> Advice inner tweakArgsInner tweakExecutionInner =
     let captureExistentials ::
-          forall ca e r outer inner.
+          forall ca e_ r outer inner.
           Proxy outer ->
           ( forall as.
             All ca as =>
             NP I as ->
-            DepT e m (outer, NP I as)
+            DepT e_ m (outer, NP I as)
           ) ->
-          ( 
-            outer ->
-            DepT e m r ->
-            DepT e m r
+          ( outer ->
+            DepT e_ m r ->
+            DepT e_ m r
           ) ->
           Proxy inner ->
           ( forall as.
             All ca as =>
             NP I as ->
-            DepT e m (inner, NP I as)
+            DepT e_ m (inner, NP I as)
           ) ->
-          ( 
-            inner ->
-            DepT e m r ->
-            DepT e m r
+          ( inner ->
+            DepT e_ m r ->
+            DepT e_ m r
           ) ->
-          Advice ca e m r
+          Advice ca e_ m r
         captureExistentials _ tweakArgsOuter' tweakExecutionOuter' _ tweakArgsInner' tweakExecutionInner' =
           Advice
             (Proxy @(Pair outer inner))
@@ -210,7 +216,7 @@                     forall as.
                     All ca as =>
                     NP I as ->
-                    DepT e m (Pair outer inner, NP I as)
+                    DepT e_ m (Pair outer inner, NP I as)
                   tweakArgs args =
                     do
                       (uOuter, argsOuter) <- tweakArgsOuter' @as args
@@ -220,17 +226,17 @@             )
             ( let tweakExecution ::
                     Pair outer inner ->
-                    DepT e m r ->
-                    DepT e m r
+                    DepT e_ m r ->
+                    DepT e_ m r
                   tweakExecution =
                     ( \(Pair uOuter uInner) action ->
                         tweakExecutionOuter' uOuter (tweakExecutionInner' uInner action)
                     )
                in tweakExecution
             )
-     in captureExistentials @ca @e outer tweakArgsOuter tweakExecutionOuter inner tweakArgsInner tweakExecutionInner
+     in captureExistentials @ca @e_ outer tweakArgsOuter tweakExecutionOuter inner tweakArgsInner tweakExecutionInner
 
-instance Monad m => Monoid (Advice ca e m r) where
+instance Monad m => Monoid (Advice ca e_ m r) where
   mappend = (<>)
   mempty = Advice (Proxy @()) (\args -> pure (pure args)) (const id)
 
@@ -249,7 +255,7 @@ --    type @u@ calculated earlier.
 --
 -- >>> :{
---  doesNothing :: forall ca e m r. Monad m => Advice ca e m r
+--  doesNothing :: forall ca e_ m r. Monad m => Advice ca e_ m r
 --  doesNothing = makeAdvice @() (\args -> pure (pure args)) (\() action -> action)
 -- :}
 --
@@ -257,20 +263,19 @@ --    type of the existential @u@ through a type application. Otherwise you'll
 --    get weird \"u is untouchable\" errors.
 makeAdvice ::
-  forall u ca e m r.
+  forall u ca e_ m r.
   -- | The function that tweaks the arguments.
   ( forall as.
     All ca as =>
     NP I as ->
-    DepT e m (u, NP I as)
+    DepT e_ m (u, NP I as)
   ) ->
   -- | The function that tweaks the execution.
-  ( 
-    u ->
-    DepT e m r ->
-    DepT e m r
+  ( u ->
+    DepT e_ m r ->
+    DepT e_ m r
   ) ->
-  Advice ca e m r
+  Advice ca e_ m r
 makeAdvice = Advice (Proxy @u)
 
 -- |
@@ -279,19 +284,19 @@ --    Notice that there's no @u@ parameter, unlike with 'makeAdvice'.
 --
 -- >>> :{
---  doesNothing :: forall ca e m r. Monad m => Advice ca e m r
+--  doesNothing :: forall ca e_ m r. Monad m => Advice ca e_ m r
 --  doesNothing = makeArgsAdvice pure
 -- :}
 makeArgsAdvice ::
-  forall ca e m r.
-  Monad m => 
+  forall ca e_ m r.
+  Monad m =>
   -- | The function that tweaks the arguments.
   ( forall as.
     All ca as =>
     NP I as ->
-    DepT e m (NP I as)
+    DepT e_ m (NP I as)
   ) ->
-  Advice ca e m r
+  Advice ca e_ m r
 makeArgsAdvice tweakArgs =
   makeAdvice @()
     ( \args -> do
@@ -306,18 +311,17 @@ --    Notice that there's no @u@ parameter, unlike with 'makeAdvice'.
 --
 -- >>> :{
---  doesNothing :: forall ca e m r. Monad m => Advice ca e m r
+--  doesNothing :: forall ca e_ m r. Monad m => Advice ca e_ m r
 --  doesNothing = makeExecutionAdvice id
 -- :}
 makeExecutionAdvice ::
-  forall ca e m r.
+  forall ca e_ m r.
   Applicative m =>
   -- | The function that tweaks the execution.
-  ( 
-    DepT e m r ->
-    DepT e m r
+  ( DepT e_ m r ->
+    DepT e_ m r
   ) ->
-  Advice ca e m r
+  Advice ca e_ m r
 makeExecutionAdvice tweakExecution = makeAdvice @() (\args -> pure (pure args)) (\() action -> tweakExecution action)
 
 data Pair a b = Pair !a !b
@@ -326,15 +330,15 @@ -- 'Ensure' is a helper for lifting typeclass definitions of the form:
 --
 -- >>> :{
---  type HasLogger :: Type -> (Type -> Type) -> Constraint
---  class HasLogger em m | em -> m where
---    logger :: em -> String -> m ()
+--  type HasLogger :: (Type -> Type) -> Type -> Constraint
+--  class HasLogger d e | e -> d where
+--    logger :: e -> String -> d ()
 -- :}
 --
--- To work as a constraints on the @e@ and @m@ parameters of an 'Advice', like this:
+-- To work as a constraints on the @e_@ and @m@ parameters of an 'Advice', like this:
 --
--- >>> :{ 
---  requiresLogger :: forall e m r. (Ensure HasLogger e m, Monad m) => Advice Show e m r
+-- >>> :{
+--  requiresLogger :: forall e_ m r. (Ensure HasLogger e_ m, Monad m) => Advice Show e_ m r
 --  requiresLogger = mempty
 --  :}
 --
@@ -344,15 +348,16 @@ -- (like those in <http://hackage.haskell.org/package/rio RIO>) whose type
 -- isn't parameterized by any monad.
 --
--- But the @e@ type parameter of 'Advice' has kind @(Type -> Type) -> Type@.
+-- But the @e_@ type parameter of 'Advice' has kind @(Type -> Type) -> Type@.
 -- That is: @NilEnv@ alone.
 --
 -- Furthermore, 'Advices' require @HasX@-style constraints to be placed on the
 -- @DepT@ transformer, not directly on the base monad @m@. @Ensure@ takes care
 -- of that as well.
-type Ensure :: (Type -> (Type -> Type) -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> Constraint
-type Ensure c e m = c (e (DepT e m)) (DepT e m) 
+type Ensure :: ((Type -> Type) -> Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> Constraint
 
+type Ensure c e_ m = c (DepT e_ m) (e_ (DepT e_ m)) 
+
 -- | Apply an 'Advice' to some compatible function. The function must have its
 -- effects in 'DepT', and all of its arguments must satisfy the @ca@ constraint.
 --
@@ -372,19 +377,19 @@ --  advisedBar2 = advise @Top returnMempty bar
 -- :}
 advise ::
-  forall ca e m r as advisee.
-  (Multicurryable as e m r advisee, All ca as, Monad m) =>
+  forall ca e_ m r as advisee.
+  (Multicurryable as e_ m r advisee, All ca as, Monad m) =>
   -- | The advice to apply.
-  Advice ca e m r ->
+  Advice ca e_ m r ->
   -- | A function to be adviced.
   advisee ->
   advisee
 advise (Advice _ tweakArgs tweakExecution) advisee = do
-  let uncurried = multiuncurry @as @e @m @r advisee
+  let uncurried = multiuncurry @as @e_ @m @r advisee
       uncurried' args = do
         (u, args') <- tweakArgs args
         tweakExecution u (uncurried args')
-   in multicurry @as @e @m @r uncurried'
+   in multicurry @as @e_ @m @r uncurried'
 
 type Multicurryable ::
   [Type] ->
@@ -393,25 +398,25 @@   Type ->
   Type ->
   Constraint
-class Multicurryable as e m r curried | curried -> as e m r where
-  type DownToBaseMonad as e m r curried :: Type
-  multiuncurry :: curried -> NP I as -> DepT e m r
-  multicurry :: (NP I as -> DepT e m r) -> curried
-  _runFromEnv :: m (e (DepT e m)) -> (e (DepT e m) -> curried) -> DownToBaseMonad as e m r curried
+class Multicurryable as e_ m r curried | curried -> as e_ m r where
+  type DownToBaseMonad as e_ m r curried :: Type
+  multiuncurry :: curried -> NP I as -> DepT e_ m r
+  multicurry :: (NP I as -> DepT e_ m r) -> curried
+  _runFromEnv :: m (e_ (DepT e_ m)) -> (e_ (DepT e_ m) -> curried) -> DownToBaseMonad as e_ m r curried
 
-instance Monad m => Multicurryable '[] e m r (DepT e m r) where
-  type DownToBaseMonad '[] e m r (DepT e m r) = m r
+instance Monad m => Multicurryable '[] e_ m r (DepT e_ m r) where
+  type DownToBaseMonad '[] e_ m r (DepT e_ m r) = m r
   multiuncurry action Nil = action
   multicurry f = f Nil
   _runFromEnv producer extractor = do
     e <- producer
     runDepT (extractor e) e
 
-instance Multicurryable as e m r curried => Multicurryable (a ': as) e m r (a -> curried) where
-  type DownToBaseMonad (a ': as) e m r (a -> curried) = a -> DownToBaseMonad as e m r curried
-  multiuncurry f (I a :* as) = multiuncurry @as @e @m @r @curried (f a) as
-  multicurry f a = multicurry @as @e @m @r @curried (f . (:*) (I a))
-  _runFromEnv producer extractor a = _runFromEnv @as @e @m @r @curried producer (\f -> extractor f a)
+instance Multicurryable as e_ m r curried => Multicurryable (a ': as) e_ m r (a -> curried) where
+  type DownToBaseMonad (a ': as) e_ m r (a -> curried) = a -> DownToBaseMonad as e_ m r curried
+  multiuncurry f (I a :* as) = multiuncurry @as @e_ @m @r @curried (f a) as
+  multicurry f a = multicurry @as @e_ @m @r @curried (f . (:*) (I a))
+  _runFromEnv producer extractor a = _runFromEnv @as @e_ @m @r @curried producer (\f -> extractor f a)
 
 -- | Given a base monad @m@ action that gets hold of the 'DepT' environment, run
 -- the 'DepT' transformer at the tip of a curried function.
@@ -423,14 +428,14 @@ --
 --  >>> runFinalDepT (pure NilEnv) foo 1 2 3 :: IO ()
 runFinalDepT ::
-  forall as e m r curried.
-  Multicurryable as e m r curried =>
+  forall as e_ m r curried.
+  Multicurryable as e_ m r curried =>
   -- | action that gets hold of the environment
-  m (e (DepT e m)) ->
+  m (e_ (DepT e_ m)) ->
   -- | function to invoke with effects in 'DepT'
   curried ->
   -- | a new function with effects in the base monad
-  DownToBaseMonad as e m r curried
+  DownToBaseMonad as e_ m r curried
 runFinalDepT producer extractor = _runFromEnv producer (const extractor)
 
 -- | Given a base monad @m@ action that gets hold of the 'DepT' environment,
@@ -461,14 +466,14 @@ -- Sum {getSum = 7}
 -- Sum {getSum = 0}
 runFromEnv ::
-  forall as e m r curried.
-  Multicurryable as e m r curried =>
+  forall as e_ m r curried.
+  Multicurryable as e_ m r curried =>
   -- | action that gets hold of the environment
-  m (e (DepT e m)) ->
+  m (e_ (DepT e_ m)) ->
   -- | gets a function from the environment with effects in 'DepT'
-  (e (DepT e m) -> curried) ->
+  (e_ (DepT e_ m) -> curried) ->
   -- | a new function with effects in the base monad
-  DownToBaseMonad as e m r curried
+  DownToBaseMonad as e_ m r curried
 runFromEnv = _runFromEnv
 
 -- $restrict
@@ -491,25 +496,23 @@ --    enough type information to the GADT, be it as an explicit signature:
 --
 -- >>> :{
---  stricterPrintArgs :: forall e m r. MonadIO m => Advice (Show `And` Eq `And` Ord) NilEnv m r
+--  stricterPrintArgs :: forall e_ m r. MonadIO m => Advice (Show `And` Eq `And` Ord) e_ m r
 --  stricterPrintArgs = restrictArgs (\Dict -> Dict) (printArgs stdout "foo")
 -- :}
 --
 --    or with a type application to 'restrictArgs':
 --
 -- >>> stricterPrintArgs = restrictArgs @(Show `And` Eq `And` Ord) (\Dict -> Dict) (printArgs stdout "foo")
---
---
 
 -- | Makes the constraint on the arguments more restrictive.
 restrictArgs ::
-  forall more less e m r.
+  forall more less e_ m r.
   -- | Evidence that one constraint implies the other. Every @x@ that has a @more@ instance also has a @less@ instance.
-  (forall x. Dict more x -> Dict less x) -> 
+  (forall x. Dict more x -> Dict less x) ->
   -- | Advice with less restrictive constraint on the args.
-  Advice less e m r ->
+  Advice less e_ m r ->
   -- | Advice with more restrictive constraint on the args.
-  Advice more e m r
+  Advice more e_ m r
 -- about the order of the type parameters... which is more useful?
 -- A possible principle to follow:
 -- We are likely to know the "less" constraint, because advices are likely to
@@ -520,24 +523,23 @@ -- type signature.  This seems to favor putting "more" first.
 restrictArgs evidence (Advice proxy tweakArgs tweakExecution) =
   let captureExistential ::
-        forall more less e m r u.
+        forall more less e_ m r u.
         (forall x. Dict more x -> Dict less x) ->
         Proxy u ->
         ( forall as.
           All less as =>
           NP I as ->
-          DepT e m (u, NP I as)
+          DepT e_ m (u, NP I as)
         ) ->
-        ( 
-          u ->
-          DepT e m r ->
-          DepT e m r
+        ( u ->
+          DepT e_ m r ->
+          DepT e_ m r
         ) ->
-        Advice more e m r
+        Advice more e_ m r
       captureExistential evidence' _ tweakArgs' tweakExecution' =
         Advice
           (Proxy @u)
-          ( let tweakArgs'' :: forall as. All more as => NP I as -> DepT e m (u, NP I as)
+          ( let tweakArgs'' :: forall as. All more as => NP I as -> DepT e_ m (u, NP I as)
                 tweakArgs'' = case Data.SOP.Dict.mapAll @more @less evidence' of
                   f -> case f (Dict @(All more) @as) of
                     Dict -> \args -> tweakArgs' @as args
@@ -545,6 +547,96 @@           )
           tweakExecution'
    in captureExistential evidence proxy tweakArgs tweakExecution
+
+--
+class Multicurryable as e_ m r curried => Deceivable as newtyped e_ m r curried where
+  type Deceived as newtyped e_ m r curried :: Type
+  _deceive :: (e_ (DepT e_ m) -> newtyped) -> Deceived as newtyped e_ m r curried -> curried
+
+instance Monad m => Deceivable '[] newtyped e_ m r (DepT e_ m r) where
+  type Deceived '[] newtyped e_ m r (DepT e_ m r) = ReaderT newtyped m r
+  _deceive f action = DepT (withReaderT f action)
+
+instance Deceivable as newtyped e_ m r curried => Deceivable (a ': as) newtyped e_ m r (a -> curried) where
+  type Deceived (a ': as) newtyped e_ m r (a -> curried) = a -> Deceived as newtyped e_ m r curried
+  _deceive f g a = deceive @as @newtyped @e_ @m @r f (g a)
+
+-- | Makes a function see a newtyped version of the environment record, a version that might have different @HasX@ instances.
+--
+-- The \"deception\" doesn't affect the dependencies used by the function, only the function itself.
+--
+-- For example, consider the following setup which features both a \"deceviced\"
+-- and an \"undeceived\" version of a controller function:
+--
+-- >>> :{
+--  type HasLogger :: (Type -> Type) -> Type -> Constraint
+--  class HasLogger d e | e -> d where
+--    logger :: e -> String -> d ()
+--  type HasIntermediate :: (Type -> Type) -> Type -> Constraint
+--  class HasIntermediate d e | e -> d where
+--    intermediate :: e -> String -> d ()
+--  type Env :: (Type -> Type) -> Type
+--  data Env m = Env
+--    { _logger1 :: String -> m (),
+--      _logger2 :: String -> m (),
+--      _intermediate :: String -> m (),
+--      _controllerA :: Int -> m (),
+--      _controllerB :: Int -> m ()
+--    }
+--  instance HasLogger m (Env m) where
+--    logger = _logger1
+--  instance HasIntermediate m (Env m) where
+--    intermediate = _intermediate
+--  newtype Switcheroo m = Switcheroo (Env m) 
+--      deriving newtype (HasIntermediate m)
+--  instance HasLogger m (Switcheroo m) where
+--    logger (Switcheroo e) = _logger2 e
+--  env :: Env (DepT Env (Writer [String]))
+--  env = 
+--    let mkController :: forall d e m. MonadDep [HasLogger, HasIntermediate] d e m => Int -> m () 
+--        mkController _ = do e <- ask; liftD $ logger e "foo" ; liftD $ intermediate e "foo"
+--        mkIntermediate :: forall d e m. MonadDep '[HasLogger] d e m => String -> m () 
+--        mkIntermediate _ = do e <- ask ; liftD $ logger e "foo" 
+--     in Env 
+--        {
+--          _logger1 = 
+--             \_ -> tell ["logger 1"],
+--          _logger2 = 
+--             \_ -> tell ["logger 2"],
+--          _intermediate =
+--             mkIntermediate, 
+--          _controllerA = 
+--             mkController,
+--          _controllerB = 
+--             deceive Switcheroo $
+--             mkController
+--        }
+-- :}
+--
+-- If we run @_controllerA@ the ouput is:
+--
+-- >>> execWriter $ runFromEnv (pure env) _controllerA 7
+-- ["logger 1","logger 1"]
+--
+-- But if we run the \"deceived\" @_controllerB@, we see that the function and its @_intermediate@ dependency use different loggers:
+--
+-- >>> execWriter $ runFromEnv (pure env) _controllerB 7
+-- ["logger 2","logger 1"]
+--
+-- Note that the function that is \"deceived\" must be polymorphic over
+-- 'Control.Monad.Dep.MonadDep'. Passing a function whose effect monad has
+-- already \"collapsed\" into 'DepT' won't work. Therefore, 'deceive' must be applied before any 'Advice'.
+--
+deceive ::
+  forall as newtyped e_ m r curried.
+  Deceivable as newtyped e_ m r curried =>
+  -- | The newtype constructor that masks the \"true\" environment.
+  (e_ (DepT e_ m) -> newtyped) ->
+  -- | A function to be deceived. It must be polymorphic over 'Control.Monad.Dep.MonadDep'.
+  Deceived as newtyped e_ m r curried ->
+  -- | The deceived function, that has effects in 'DepT'.
+  curried
+deceive = _deceive
 
 -- $sop
 -- Some useful definitions re-exported the from \"sop-core\" package.

@@ -54,7 +54,6 @@ -- >>> import Control.Monad.Dep
 -- >>> import Control.Monad.Dep.Advice
 -- >>> import Control.Monad.Dep.Advice.Basic (printArgs,returnMempty)
--- >>> import Data.Constraint
 -- >>> import Data.Kind
 -- >>> import Data.SOP
 -- >>> import Data.SOP.NP
@@ -68,7 +67,7 @@ --
 -- Because it doesn't touch the arguments or require some effect from the
 -- environment, this 'Advice' is polymorphic on @ca@ and @cem@.
-returnMempty :: forall ca e m r. (Monad m, Monoid r) => Advice ca e m r
+returnMempty :: forall ca e_ m r. (Monad m, Monoid r) => Advice ca e_ m r
 returnMempty =
   makeExecutionAdvice
     ( \action -> do
@@ -84,7 +83,7 @@ --
 -- Because it doesn't touch the return value of the advised function, this
 -- 'Advice' is polymorphic on @cr@.
-printArgs :: forall e m r. MonadIO m => Handle -> String -> Advice Show e m r
+printArgs :: forall e_ m r. MonadIO m => Handle -> String -> Advice Show e_ m r
 printArgs h prefix =
   makeArgsAdvice
     ( \args -> do
@@ -98,8 +97,12 @@ -- | Use 'local' on the final 'DepT' action of a function.
 --
 -- Allows tweaking the environment that will be seen by the function and all of
--- its sub-calls.
+-- its sub-calls into dependencies. 
 --
+-- Note that perhaps this is __not__ what you want; often it's better to tweak
+-- the environment for the current function only. For those cases,
+-- 'Control.Monad.Dep.Advice.deceive' might be a better fit. 
+--
 -- >>> :{
 --  type HasLogger :: Type -> (Type -> Type) -> Constraint
 --  class HasLogger em m | em -> m where
@@ -116,12 +119,16 @@ --  envIO :: Env (DepT Env IO)
 --  envIO = Env 
 --    {
---      _logger1 = \_ -> liftIO $ putStrLn "logger1 ran",
---      _logger2 = \_ -> liftIO $ putStrLn "logger2 ran",
---      _controllerA = \_ -> do e <- ask; logger e "foo",
---      _controllerB = advise @Top 
---                     (doLocally \e@Env{_logger2} -> e {_logger1 = _logger2}) 
---                     \_ -> do e <- ask; logger e "foo" 
+--      _logger1 = 
+--          \_ -> liftIO $ putStrLn "logger1 ran",
+--      _logger2 = 
+--          \_ -> liftIO $ putStrLn "logger2 ran",
+--      _controllerA = 
+--          \_ -> do e <- ask; logger e "foo",
+--      _controllerB = 
+--          advise @Top 
+--          (doLocally \e@Env{_logger2} -> e {_logger1 = _logger2}) 
+--          \_ -> do e <- ask; logger e "foo" 
 --    }
 -- :}
 --
@@ -131,7 +138,7 @@ --  >>> runFromEnv (pure envIO) _controllerB 0
 --  logger2 ran
 --
-doLocally :: forall ca e m r. Monad m => (forall n. e n -> e n) -> Advice ca e m r 
+doLocally :: forall ca e_ m r. Monad m => (forall n. e_ n -> e_ n) -> Advice ca e_ m r 
 doLocally transform = makeExecutionAdvice (local transform)  
 
 
@@ -162,7 +169,7 @@ --
 -- A better implementation of this advice would likely use an @AnyHashable@
 -- helper datatype for the keys.
-doCachingBadly :: forall e m r. Monad m => (AnyEq -> m (Maybe r)) -> (AnyEq -> r -> m ()) -> Advice (Eq `And` Typeable) e m r
+doCachingBadly :: forall e_ m r. Monad m => (AnyEq -> m (Maybe r)) -> (AnyEq -> r -> m ()) -> Advice (Eq `And` Typeable) e_ m r
 doCachingBadly cacheLookup cachePut =
   makeAdvice @AnyEq
     ( \args ->
@@ -186,7 +193,7 @@ -- package instead of bare `forkIO`. 
 --
 -- And the @MustBe IO@ constraint could be relaxed to @MonadUnliftIO@.
-doAsyncBadly :: forall ca e. Advice ca e IO ()
+doAsyncBadly :: forall ca e_ . Advice ca e_ IO ()
 doAsyncBadly = makeExecutionAdvice (\action -> do
         e <- ask 
         _ <- liftIO $ forkIO $ runDepT action e

@@ -12,6 +12,7 @@ {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
 
 module Main (main) where
 
@@ -36,29 +37,29 @@ -- Has-style typeclasses can be provided to avoid depending on concrete
 -- environments.
 -- Note that the environment determines the monad.
-type HasLogger :: Type -> (Type -> Type) -> Constraint
-class HasLogger r m | r -> m where
-  logger :: r -> String -> m ()
+type HasLogger :: (Type -> Type) -> Type -> Constraint
+class HasLogger d r | r -> d where
+  logger :: r -> String -> d ()
 
 -- Possible convenience function to avoid having to use ask before logging
 -- Worth the extra boilerplate, or not?
-logger' :: (MonadReader e m, HasLogger e m) => String -> m ()
-logger' msg = asks logger >>= \f -> f msg
+loggerD :: MonadDep '[HasLogger] d e m => String -> m ()
+loggerD msg = asks logger >>= \f -> liftD $ f msg
 
-type HasRepository :: Type -> (Type -> Type) -> Constraint
-class HasRepository r m | r -> m where
-  repository :: r -> Int -> m ()
+type HasRepository :: (Type -> Type) -> Type -> Constraint
+class HasRepository d r | r -> d where
+  repository :: r -> Int -> d ()
 
 -- Some possible implementations.
 --
 -- An implementation of the controller, done programming against interfaces
 -- (well, against typeclasses).
 -- Polymorphic on the monad.
-mkController :: (MonadReader e m, HasLogger e m, HasRepository e m) => Int -> m String
+mkController :: MonadDep [HasLogger, HasRepository] d e m => Int -> m String
 mkController x = do
   e <- ask
-  logger e "I'm going to insert in the db!"
-  repository e x
+  liftD $ logger e "I'm going to insert in the db!"
+  liftD $ repository e x
   return "view"
 
 -- A "real" logger implementation that interacts with the external world.
@@ -66,10 +67,10 @@ mkStdoutLogger msg = liftIO (putStrLn msg)
 
 -- A "real" repository implementation
-mkStdoutRepository :: (MonadReader e m, HasLogger e m, MonadIO m) => Int -> m ()
+mkStdoutRepository :: (MonadDep '[HasLogger] d e m, MonadIO m) => Int -> m ()
 mkStdoutRepository entity = do
   e <- ask
-  logger e "I'm going to write the entity!"
+  liftD $ logger e "I'm going to write the entity!"
   liftIO $ print entity
 
 -- The traces we accumulate from the fakes during tests
@@ -80,10 +81,10 @@ mkFakeLogger msg = tell ([msg], mempty)
 
 -- Ditto.
-mkFakeRepository :: (MonadReader e m, HasLogger e m, MonadWriter TestTrace m) => Int -> m ()
+mkFakeRepository :: (MonadDep '[HasLogger] d e m, MonadWriter TestTrace m) => Int -> m ()
 mkFakeRepository entity = do
   e <- ask
-  logger e "I'm going to write the entity!"
+  liftD $ logger e "I'm going to write the entity!"
   tell ([], [entity])
 
 --
@@ -95,10 +96,10 @@     _repositoryIO :: Int -> IO ()
   }
 
-instance HasLogger EnvIO IO where
+instance HasLogger IO EnvIO where
   logger = _loggerIO
 
-instance HasRepository EnvIO IO where
+instance HasRepository IO EnvIO where
   repository = _repositoryIO
 
 -- In the monomorphic environment, the controller function lives "separate",
@@ -112,7 +113,7 @@ -- In a sufficiently complex app, the diverse functions will form a DAG of
 -- dependencies between each other. So it would be nice if the functions were
 -- treated uniformly, all having access to (views of) the environment record.
-mkControllerIO :: (HasLogger e IO, HasRepository e IO) => Int -> ReaderT e IO String
+mkControllerIO :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String
 mkControllerIO x = do
   e <- ask
   liftIO $ logger e "I'm going to insert in the db!"
@@ -134,10 +135,10 @@ 
 -- If our environment is parmeterized by the monad m, then logging is done in
 -- m.
-instance HasLogger (Env m) m where
+instance HasLogger m (Env m) where
   logger = _logger
 
-instance HasRepository (Env m) m where
+instance HasRepository m (Env m) where
   repository = _repository
 
 -- This bigger environment is for demonstrating how to "nest" environments.
@@ -272,28 +273,28 @@     _logger2 :: String -> m ()
     }
 
-instance HasLogger (CachingTestEnv m) m where
+instance HasLogger m (CachingTestEnv m) where
   logger = _logger2
 
-type HasExpensiveComputation :: Type -> (Type -> Type) -> Constraint
-class HasExpensiveComputation r m | r -> m where
-  expensiveComputation :: r -> Int -> Bool -> m String
-instance HasExpensiveComputation (CachingTestEnv m) m where
+type HasExpensiveComputation :: (Type -> Type) -> Type -> Constraint
+class HasExpensiveComputation d r | r -> d where
+  expensiveComputation :: r -> Int -> Bool -> d String
+instance HasExpensiveComputation m (CachingTestEnv m) where
   expensiveComputation = _expensiveComputation 
 
-mkFakeExpensiveComputation :: (MonadReader e m, HasLogger e m) => Int -> Bool -> m String
+mkFakeExpensiveComputation :: MonadDep '[HasLogger] d e m => Int -> Bool -> m String
 mkFakeExpensiveComputation i b = do
     e <- ask
-    logger e "Doing expensive computation"
+    liftD $ logger e "Doing expensive computation"
     return $ (show i ++ show b)
 
-cacheTestLogic :: (MonadReader e m, HasLogger e m, HasExpensiveComputation e m) => m ()
+cacheTestLogic :: MonadDep [HasLogger, HasExpensiveComputation] d e m => m ()
 cacheTestLogic = do
     e <- ask
-    expensiveComputation e 0 False >>= logger e
-    expensiveComputation e 1 True >>= logger e
-    expensiveComputation e 0 False >>= logger e
-    expensiveComputation e 1 True >>= logger e
+    liftD $ expensiveComputation e 0 False >>= logger e
+    liftD $ expensiveComputation e 1 True >>= logger e
+    liftD $ expensiveComputation e 0 False >>= logger e
+    liftD $ expensiveComputation e 1 True >>= logger e
 
 type ExpensiveComputationMonad = RWS () ([String],()) [(AnyEq,String)]