dep-t-advice 0.6.1.0 → 0.6.2.0

raw patch · 21 files changed

+5463/−4153 lines, 21 filesdep ~dep-tdep ~doctestsetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: dep-t, doctest

API changes (from Hackage documentation)

Files

• CHANGELOG.md +99/−95
• LICENSE +30/−30
• README.md +211/−199
• Setup.hs +2/−2
• benchmark/benchmarks.hs +70/−70
• dep-t-advice.cabal +125/−120
• lib/Dep/Advice.hs +1019/−1019
• lib/Dep/Advice/Basic.hs +194/−194
• lib/Dep/IOAdvice.hs +533/−0
• lib/Dep/IOAdvice/Basic.hs +89/−0
• lib/Dep/ReaderAdvice.hs +540/−0
• lib/Dep/ReaderAdvice/Basic.hs +123/−0
• lib/Dep/SimpleAdvice.hs +495/−495
• lib/Dep/SimpleAdvice/Basic.hs +273/−273
• lib/Dep/SimpleAdvice/Internal.hs +126/−126
• test/doctests.hs +16/−12
• test/simple-advice-tests.hs +178/−178
• test/synthetic-callstack-tests.hs +548/−548
• test/tests-has-conversion.hs +210/−210
• test/tests.hs +379/−379
• test/weird-advice-tests.hs +203/−203

@@ -1,95 +1,99 @@-# 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 
-
-* 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`. 
-
-  The old modules still remain, but deprecated.
-
-* Added `fromSimple_`.
-
-* Added `injectFailures` and `keepCallStack`.
-
-## 0.5.0.0 
-
-* The Advice type has changed to get rid of the existential type.
-  This breaks the 'makeAdvice' function.   
-* Added 'Control.Monad.Dep.SimpleAdvice' and 'Control.Monad.Dep.SimpleAdvice.Basic'.
-* Moved some "basic" advices.
-* Removed distributeDepT.
-* 'adviseRecord' now receives a 'NonEmpty' path-in-record, ordered innermost-first.
-* More flexible type for doLocally.
-
-## 0.4.7.0 
-
-* Added 'distributeDepT' and 'component'.
-
-## 0.4.6.1 
-
-* Modified a signature to make it compile with GHC 9.0.1.
-
-## 0.4.6.0 
-
-* `adviseRecord` and `deceiveRecord` now work with records having fields wrapped in `Identity`.
-
-  This is for better compatibility with the [barbies](http://hackage.haskell.org/package/barbies) package.
-
-## 0.4.5.0 
-
-* Added runFromDep.
-
-  This required bumping the minimum version of dep-t to 0.4.4.0.
-
-## 0.4.4.0 
-
-* Added 'adviseRecord' and 'deceiveRecord' that manipulate entire
-  records-of-functions (also work on newtypes) instead of a single bare
-  function. 
-
-  Useful when the components to put on the environment come in their own record
-  types.
-
-## 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
-  dependency footprint. This changes the signature of restrictArgs.
-
-## 0.2.0.0 
-
-* BREAKING CHANGE. The Advice type is no longer parameterized by the `cem` and
-  `cr` constraints. Instead, it's directly parameterized by the types `e` of
-  the environment, `m` of the base monad and `r` of the result, which are left
-  polymorphic when needed. This simplifies a bunch of things. The `ca`
-  constraint paramter remains however.
-
-## 0.1.0.0 -- YYYY-mm-dd
-
-* First version. Released on an unsuspecting world.
+# Revision history for dep-t-advice++## 0.6.2.0++* Add `Dep.ReaderAdvice` and `Dep.IOAdvice`.++## 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 ++* 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`. ++  The old modules still remain, but deprecated.++* Added `fromSimple_`.++* Added `injectFailures` and `keepCallStack`.++## 0.5.0.0 ++* The Advice type has changed to get rid of the existential type.+  This breaks the 'makeAdvice' function.   +* Added 'Control.Monad.Dep.SimpleAdvice' and 'Control.Monad.Dep.SimpleAdvice.Basic'.+* Moved some "basic" advices.+* Removed distributeDepT.+* 'adviseRecord' now receives a 'NonEmpty' path-in-record, ordered innermost-first.+* More flexible type for doLocally.++## 0.4.7.0 ++* Added 'distributeDepT' and 'component'.++## 0.4.6.1 ++* Modified a signature to make it compile with GHC 9.0.1.++## 0.4.6.0 ++* `adviseRecord` and `deceiveRecord` now work with records having fields wrapped in `Identity`.++  This is for better compatibility with the [barbies](http://hackage.haskell.org/package/barbies) package.++## 0.4.5.0 ++* Added runFromDep.++  This required bumping the minimum version of dep-t to 0.4.4.0.++## 0.4.4.0 ++* Added 'adviseRecord' and 'deceiveRecord' that manipulate entire+  records-of-functions (also work on newtypes) instead of a single bare+  function. ++  Useful when the components to put on the environment come in their own record+  types.++## 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+  dependency footprint. This changes the signature of restrictArgs.++## 0.2.0.0 ++* BREAKING CHANGE. The Advice type is no longer parameterized by the `cem` and+  `cr` constraints. Instead, it's directly parameterized by the types `e` of+  the environment, `m` of the base monad and `r` of the result, which are left+  polymorphic when needed. This simplifies a bunch of things. The `ca`+  constraint paramter remains however.++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -1,30 +1,30 @@-Copyright (c) 2021, Daniel Diaz
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-
-    * Redistributions in binary form must reproduce the above
-      copyright notice, this list of conditions and the following
-      disclaimer in the documentation and/or other materials provided
-      with the distribution.
-
-    * Neither the name of Daniel Diaz nor the names of other
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright (c) 2021, Daniel Diaz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Daniel Diaz nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,199 +1,211 @@-# dep-t-advice
-
-This package is a companion to
-[dep-t](http://hackage.haskell.org/package/dep-t). It provides a mechanism for
-handling cross-cutting concerns in your application by adding "advices" to the
-functions in your record-of-functions, in a way that is composable and
-independent of each function's particular number of arguments.
-
-[![dep-t-advice.png](https://i.postimg.cc/L8Cm279S/dep-t-advice.png)](https://postimg.cc/tsxKzBnv)
-
-## Rationale
-
-So, you have decided to structure your program in a record-of-functions style,
-using [dep-t](http://hackage.haskell.org/package/dep-t). Good choice!
-
-You have already selected your functions, decided which base monad use for
-`DepT`, and now you are ready to construct the environment record, which serves
-as your [composition
-root](https://stackoverflow.com/questions/6277771/what-is-a-composition-root-in-the-context-of-dependency-injection).
-
-Now seems like a good moment to handle some of those pesky ["croscutting
-concerns"](https://en.wikipedia.org/wiki/Cross-cutting_concern), don't you
-think?
-
-Stuff like:
-
-- Logging
-- Caching
-- Monitoring
-- Validation
-- Setting up transaction boundaries.
-- Setting up exception handlers for uncaught exceptions.
-
-But how will you go about it?
-
-### A perfectly simple and reasonable solution
-
-Imagine that you want to make this function print its argument to stdout:
-
-    foo :: Int -> DepT e_ IO () 
-
-Easy enough:
-
-    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 f arg1 = do
-        liftIO $ putStrLn (show arg1)
-        f arg1
-
-You could wrap `foo` in `printArgs` when constructing the record-of-functions,
-or perhaps you could modify the corresponding field after the record had been
-constructed.
-
-This solution works, and is easy to understand. There's an annoyance though:
-you need a different version of `printArgs` for each number of arguments a
-function might have.
-
-And if you want to compose different combinators (say, `printArgs` and
-`printResult`) before applying them to functions, you need a composition
-combinator specific for each number of arguments.
-
-### The solution using "advices"
-
-The `Advice` datatype provided by this package encapsulates a transformation on
-`DepT`-effectful functions, *in a way that is polymorphic over the number of
-arguments*. The same advice will work for functions with `0`, `1` or `N`
-arguments.
-
-Advices can't change the type of a function, but they might:
-
-- Analyze and change the values of the function's arguments.
-
-- Add additional effects to the function, either effects from the base monad, or effects from handlers found in the environment.
-
-- Change the result value of the function.
-
-- Sidestep the execution of the function altogether, providing al alternative result.
-
-Here's how a `printArgs` advice might be defined:
-
-    printArgs :: forall e_ m r. MonadIO m => Handle -> String -> Advice Show e_ m r
-    printArgs h prefix =
-      makeArgsAdvice
-        ( \args -> do
-            liftIO $ hPutStr h $ prefix ++ ":"
-            hctraverse_ (Proxy @Show) (\(I a) -> liftIO (hPutStr h (" " ++ show a))) args
-            liftIO $ hPutStrLn h "\n"
-            liftIO $ hFlush h
-            pure args
-        )
-
-The advice receives the arguments of the function in the form of an [n-ary
-product](http://hackage.haskell.org/package/sop-core-0.5.0.1/docs/Data-SOP-NP.html#t:NP)
-from [sop-core](http://hackage.haskell.org/package/sop-core-0.5.0.1). But it
-must be polymorphic on the shape of the type-level list which indexes the
-product. This makes the advice work for any number of parameters.
-
-The advice would be applied like this:
-
-    advise (printArgs stdout "foo args: ") foo
-
-## Advices should be applied at the composition root
-
-It's worth emphasizing that advices should be applied at the ["composition
-root"](https://stackoverflow.com/questions/6277771/what-is-a-composition-root-in-the-context-of-dependency-injection),
-the place in our application in which all the disparate functions are assembled
-and we commit to a concrete monad, namely `DepT`.
-
-Before being brought into the composition root, the functions need not be aware
-that `DepT` exists. They might be working in some generic `MonadReader`
-environment, plus some constraints on that environment.
-
-Once we decide to use `DepT`, we can apply the advice, because advice only
-works on functions that end on a `DepT` action. Also, advice might depend on
-the full gamut of functionality stored in the environment.
-
-## What about `Dep.SimpleAdvice`?
-
-`Advice`s form `Dep.Advice` work with the `DepT` monad, but
-that's a bit too specialized. What if I want to use plain `IO` as the monad
-which parameterizes my record-of-functions?
-
-`Dep.SimpleAdvice` provides a version of the `Advice` type that
-works with records-of-functions parameterized with `IO` or other concrete
-monads. 
-
-This simpler `Advice` can be useful when performing dependency injection
-through [`fixEnv`](https://hackage.haskell.org/package/dep-t-0.5.0.0/docs/Control-Monad-Dep-Env.html#v:fixEnv).
-
-There are conversion functions between the two versions of `Advice`.
-
-See [this thread](https://discourse.haskell.org/t/decorate-your-records-of-functions-with-this-weird-trick/3675) in the Haskell Discourse for more info.
-
-## Historical aside
-
-According to Wikipedia, the term "advice" in the sense of aspect-oriented
-programming goes back to 1966. Quoting from [PILOT: A Step Toward Man-Computer
-Symbiosis](http://publications.csail.mit.edu/ai/browse/0200browse.shtml):
-
-> There are two ways a user can modify programs in this subjective model of
-> programming: he can modify the interface between procedures, or he can modify
-> the procedure itself. (Since procedures are themselves made up of procedures,
-> modifying a procedure at one level may correspond to modifying the interface
-> between procedures at a lower level.) Modifying the interface between
-> procedures is called advising. Modifying a procedure itself is editing.
-
-> Advising is the basic innovation in the model, and in the PILOT system.
-> Advising consists of inserting new procedures at any or all of the entry or
-> exit points to a particular procedure (or class of procedures). The
-> procedures inserted are called "advice procedures" or simply "advice".
-
-> Since each piece of advice is itself a procedure, it has its own entries and
-> exits. In particular, this means that the execution of advice can cause the
-> procedure that it modifies to be bypassed completely, e.g., by specifying as
-> an exit from the advice one of the exits from the original procedure; or the
-> advice may change essential variables and continue with the computation so
-> that the original procedure is executed, but with modified variables.
-> Finally, the advice may not alter the execution or affect the original
-> procedure at all, e.g., it may merely perform some additional computation
-> such as printing a message or recording history. Since advice can be
-> conditional, the decision as to what is to be done can depend on the results
-> of the computation up to that point.
-
-> The principal advantage of advising is that the user need not be concerned
-> about the details of the actual changes in his program, nor the internal
-> representation of advice. He can treat the procedure to be advised *as a
-> unit*, a single block, and make changes to it without concern for the
-> particulars of this block. This may be contrasted with editing in which the
-> programmer must be cognizant of the internal structure of the procedure.
-
-[tweet](https://twitter.com/DiazCarrete/status/1446783366678949891).
-
-## Links
-
-- [Aspect Oriented Programming with
-  Spring](https://docs.spring.io/spring-framework/docs/current/reference/html/core.html#aop)
-  and [Spring AOP
-  APIs](https://docs.spring.io/spring-framework/docs/current/reference/html/core.html#aop-api).
-
-- [Using the “constraints” package to make a wrapped function less
-  polymorphic](https://stackoverflow.com/questions/65800809/using-the-constraints-package-to-make-a-wrapped-function-less-polymorphic)
-
-- [variadic-function](https://hackage.haskell.org/package/variadic-function) a
-  Hackage library which also deals with functions of any number of elements.
-  [Reddit
-  thread](https://www.reddit.com/r/haskell/comments/oeyaz2/ann_typeablemock_mocks_that_can_fit_into_any/).
-
-- [Inferring the arity of zipWith, with lots of type-level hackery](https://www.youtube.com/watch?v=iGSKqcebhfs&t=957s). YouTube video.
-
-- [Functional Pearl: The Decorator Pattern in Haskell](https://twitter.com/DiazCarrete/status/1403985337513394178)
-
-  > An arity-generic decorator needs to solve two problems: intercept recursive calls and handle functions of any arity uniformly
-
+# dep-t-advice++This package is a companion to+[dep-t](http://hackage.haskell.org/package/dep-t). It provides a mechanism for+handling cross-cutting concerns in your application by adding "advices" to the+functions in your record-of-functions, in a way that is composable and+independent of each function's particular number of arguments.++[![dep-t-advice.png](https://i.postimg.cc/L8Cm279S/dep-t-advice.png)](https://postimg.cc/tsxKzBnv)++## Rationale++So, you have decided to structure your program in a record-of-functions style,+using [dep-t](http://hackage.haskell.org/package/dep-t). Good choice!++You have already selected your functions, decided which base monad use for+`DepT`, and now you are ready to construct the environment record, which serves+as your [composition+root](https://stackoverflow.com/questions/6277771/what-is-a-composition-root-in-the-context-of-dependency-injection).++Now seems like a good moment to handle some of those pesky ["croscutting+concerns"](https://en.wikipedia.org/wiki/Cross-cutting_concern), don't you+think?++Stuff like:++- Logging+- Caching+- Monitoring+- Validation+- Setting up transaction boundaries.+- Setting up exception handlers for uncaught exceptions.++But how will you go about it?++### A perfectly simple and reasonable solution++Imagine that you want to make this function print its argument to stdout:++    foo :: Int -> DepT e_ IO () ++Easy enough:++    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 f arg1 = do+        liftIO $ putStrLn (show arg1)+        f arg1++You could wrap `foo` in `printArgs` when constructing the record-of-functions,+or perhaps you could modify the corresponding field after the record had been+constructed.++This solution works, and is easy to understand. There's an annoyance though:+you need a different version of `printArgs` for each number of arguments a+function might have.++And if you want to compose different combinators (say, `printArgs` and+`printResult`) before applying them to functions, you need a composition+combinator specific for each number of arguments.++### The solution using "advices"++The `Advice` datatype provided by this package encapsulates a transformation on+`DepT`-effectful functions, *in a way that is polymorphic over the number of+arguments*. The same advice will work for functions with `0`, `1` or `N`+arguments.++Advices can't change the type of a function, but they might:++- Analyze and change the values of the function's arguments.++- Add additional effects to the function, either effects from the base monad, or effects from handlers found in the environment.++- Change the result value of the function.++- Sidestep the execution of the function altogether, providing al alternative result.++Here's how a `printArgs` advice might be defined:++    printArgs :: forall e_ m r. MonadIO m => Handle -> String -> Advice Show e_ m r+    printArgs h prefix =+      makeArgsAdvice+        ( \args -> do+            liftIO $ hPutStr h $ prefix ++ ":"+            hctraverse_ (Proxy @Show) (\(I a) -> liftIO (hPutStr h (" " ++ show a))) args+            liftIO $ hPutStrLn h "\n"+            liftIO $ hFlush h+            pure args+        )++The advice receives the arguments of the function in the form of an [n-ary+product](http://hackage.haskell.org/package/sop-core-0.5.0.1/docs/Data-SOP-NP.html#t:NP)+from [sop-core](http://hackage.haskell.org/package/sop-core-0.5.0.1). But it+must be polymorphic on the shape of the type-level list which indexes the+product. This makes the advice work for any number of parameters.++The advice would be applied like this:++    advise (printArgs stdout "foo args: ") foo++## Advices should be applied at the composition root++It's worth emphasizing that advices should be applied at the ["composition+root"](https://stackoverflow.com/questions/6277771/what-is-a-composition-root-in-the-context-of-dependency-injection),+the place in our application in which all the disparate functions are assembled+and we commit to a concrete monad, namely `DepT`.++Before being brought into the composition root, the functions need not be aware+that `DepT` exists. They might be working in some generic `MonadReader`+environment, plus some constraints on that environment.++Once we decide to use `DepT`, we can apply the advice, because advice only+works on functions that end on a `DepT` action. Also, advice might depend on+the full gamut of functionality stored in the environment.++## What about  `Dep.ReaderAdvice` and `Dep.IOAdvice`?++`Advice`s from `Dep.Advice` require us to work with `DepT`, but `DepT` is kind+of weird. Instead, we may might to use more common monads for our effects, like+`ReaderT` o plain old `IO`.++That's why `Dep.ReaderAdvice` and `Dep.IOAdvice` exist: they provide alternative+versions of the `Advice` type which work with those monads.++Ain't that a lot of code duplication? Why not have a single `Advice` type which+works with all monads? That leads us to...++## What about `Dep.SimpleAdvice`?++`Dep.SimpleAdvice` provides a version of the `Advice` type that can be used with+different concrete monads like `ReaderT` or `IO`.++See [this+thread](https://discourse.haskell.org/t/decorate-your-records-of-functions-with-this-weird-trick/3675)+in the Haskell Discourse for more info.++There's a catch, however. `Dep.SimpleAdvice` depends on the `coerce` mechanism+of Haskell, and it can sometimes be finicky, for example when some required+constructor hasn't been imported, or when there are polymorphic functions+involved.++That's the reason `Dep.ReaderAdvice` and `Dep.IOAdvice` are still necessary. For+their particular monads, they work in more cases.++## Historical aside++According to Wikipedia, the term "advice" in the sense of aspect-oriented+programming goes back to 1966. Quoting from [PILOT: A Step Toward Man-Computer+Symbiosis](http://publications.csail.mit.edu/ai/browse/0200browse.shtml):++> There are two ways a user can modify programs in this subjective model of+> programming: he can modify the interface between procedures, or he can modify+> the procedure itself. (Since procedures are themselves made up of procedures,+> modifying a procedure at one level may correspond to modifying the interface+> between procedures at a lower level.) Modifying the interface between+> procedures is called advising. Modifying a procedure itself is editing.++> Advising is the basic innovation in the model, and in the PILOT system.+> Advising consists of inserting new procedures at any or all of the entry or+> exit points to a particular procedure (or class of procedures). The+> procedures inserted are called "advice procedures" or simply "advice".++> Since each piece of advice is itself a procedure, it has its own entries and+> exits. In particular, this means that the execution of advice can cause the+> procedure that it modifies to be bypassed completely, e.g., by specifying as+> an exit from the advice one of the exits from the original procedure; or the+> advice may change essential variables and continue with the computation so+> that the original procedure is executed, but with modified variables.+> Finally, the advice may not alter the execution or affect the original+> procedure at all, e.g., it may merely perform some additional computation+> such as printing a message or recording history. Since advice can be+> conditional, the decision as to what is to be done can depend on the results+> of the computation up to that point.++> The principal advantage of advising is that the user need not be concerned+> about the details of the actual changes in his program, nor the internal+> representation of advice. He can treat the procedure to be advised *as a+> unit*, a single block, and make changes to it without concern for the+> particulars of this block. This may be contrasted with editing in which the+> programmer must be cognizant of the internal structure of the procedure.++[tweet](https://twitter.com/DiazCarrete/status/1446783366678949891).++## Links++- [Aspect Oriented Programming with+  Spring](https://docs.spring.io/spring-framework/docs/current/reference/html/core.html#aop)+  and [Spring AOP+  APIs](https://docs.spring.io/spring-framework/docs/current/reference/html/core.html#aop-api).++- [Using the “constraints” package to make a wrapped function less+  polymorphic](https://stackoverflow.com/questions/65800809/using-the-constraints-package-to-make-a-wrapped-function-less-polymorphic)++- [variadic-function](https://hackage.haskell.org/package/variadic-function) a+  Hackage library which also deals with functions of any number of elements.+  [Reddit+  thread](https://www.reddit.com/r/haskell/comments/oeyaz2/ann_typeablemock_mocks_that_can_fit_into_any/).++- [Inferring the arity of zipWith, with lots of type-level hackery](https://www.youtube.com/watch?v=iGSKqcebhfs&t=957s). YouTube video.++- [Functional Pearl: The Decorator Pattern in Haskell](https://twitter.com/DiazCarrete/status/1403985337513394178)++  > An arity-generic decorator needs to solve two problems: intercept recursive calls and handle functions of any arity uniformly+

@@ -1,2 +1,2 @@-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple+main = defaultMain

@@ -1,70 +1,70 @@-{-# 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 (id, args))
-
-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))
-        ]
-    ] 
-
+{-# 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 (id, args))++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,120 +1,125 @@-cabal-version:       3.0
-
-name:                dep-t-advice
-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
-                     functions living in a record-of-functions, whatever the
-                     number of arguments they might have.
-                     
-                     In other words: something like the "advices" of
-                     aspect-oriented programming.
-
-                     Two flavors of advice are provided: one for environments
-                     parameterized by the DepT monad, and a simpler version for
-                     environments parameterized by IO and other monads.
--- bug-reports:
-license:             BSD-3-Clause
-license-file:        LICENSE
-author:              Daniel Diaz
-maintainer:          diaz_carrete@yahoo.com
-category:            Control
-extra-source-files:  CHANGELOG.md, README.md
-
-source-repository    head
-  type:     git
-  location: https://github.com/danidiaz/dep-t-advice.git
-
-common common
-  build-depends:       base >=4.10.0.0 && < 5,
-                       sop-core ^>= 0.5.0.0,
-                       transformers ^>= 0.5.0.0,
-                       dep-t >= 0.6.1 && < 0.7,
-                       mtl ^>= 2.2,
-                       unliftio-core ^>= 0.2.0.0,
-  default-language:    Haskell2010
-
-common common-tests
-  import:              common
-  build-depends:       
-                       dep-t-advice, 
-                       rank2classes       ^>= 1.4.1,
-                       -- transformers       ^>= 0.5.0.0,
-                       -- mtl                ^>= 2.2,
-                       template-haskell,
-                       text,
-
-common common-tasty
-  import:              common-tests
-  hs-source-dirs:      test
-  build-depends:       
-                       tasty              >= 1.3.1,
-                       tasty-hunit        >= 0.10.0.2,
-
-library
-  import: common
-  exposed-modules:     Dep.Advice
-                       Dep.Advice.Basic
-                       Dep.SimpleAdvice
-                       Dep.SimpleAdvice.Basic
-  other-modules:       Dep.SimpleAdvice.Internal    
-                        
-  hs-source-dirs:      lib 
-
-test-suite tests
-  import:              common-tasty
-  type:                exitcode-stdio-1.0
-  main-is:             tests.hs
-
-test-suite weird-advice-tests
-  import:              common-tasty
-  type:                exitcode-stdio-1.0
-  main-is:             weird-advice-tests.hs
-  build-depends:       
-                       barbies            ^>= 2.0.2.0
-
-test-suite simple-advice-tests
-  import:              common-tasty
-  type:                exitcode-stdio-1.0
-  main-is:             simple-advice-tests.hs
-  build-depends:       
-                       barbies            ^>= 2.0.2.0
-
-test-suite tests-has-conversion
-  import:              common-tasty
-  type:                exitcode-stdio-1.0
-  main-is:             tests-has-conversion.hs
-  build-depends:       aeson,
-                       containers
-
-test-suite synthetic-callstack-tests
-  import:              common-tasty
-  type:                exitcode-stdio-1.0
-  main-is:             synthetic-callstack-tests.hs
-  build-depends:       aeson,
-                       containers,
-                       microlens ^>= 0.4.12.0
-
--- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288
--- http://hackage.haskell.org/package/cabal-doctest
-test-suite doctests
-  import:              common-tests
-  ghc-options:         -threaded
-  type:                exitcode-stdio-1.0
-  hs-source-dirs:      test
-  main-is:             doctests.hs
-  build-depends:       
-                       doctest            ^>= 0.18 
-                       
- -- 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,  
-
-
+cabal-version:       3.0++name:                dep-t-advice+version:             0.6.2.0+synopsis:            Giving good advice to functions in records-of-functions.+description:         +                     Companion to the dep-t package. Easily add behaviour to+                     functions living in a record-of-functions, whatever the+                     number of arguments they might have.+                     +                     In other words: something like the "advices" of+                     aspect-oriented programming.++                     Various flavors of advice are provided: one for+                     environments parameterized by the DepT monad, and others+                     for environments parameterized by ReaderT, IO and generic+                     monads.+-- bug-reports:+license:             BSD-3-Clause+license-file:        LICENSE+author:              Daniel Diaz+maintainer:          diaz_carrete@yahoo.com+category:            Control+extra-source-files:  CHANGELOG.md, README.md++source-repository    head+  type:     git+  location: https://github.com/danidiaz/dep-t-advice.git++common common+  build-depends:       base >=4.10.0.0 && < 5,+                       sop-core ^>= 0.5.0.0,+                       transformers >= 0.5.0.0,+                       dep-t ^>= 0.6.1,+                       mtl >= 2.2,+                       unliftio-core >= 0.2.0.0,+  default-language:    Haskell2010++common common-tests+  import:              common+  build-depends:       +                       dep-t-advice, +                       rank2classes       ^>= 1.4.1,+                       -- transformers       ^>= 0.5.0.0,+                       -- mtl                ^>= 2.2,+                       template-haskell,+                       text,++common common-tasty+  import:              common-tests+  hs-source-dirs:      test+  build-depends:       +                       tasty              >= 1.3.1,+                       tasty-hunit        >= 0.10.0.2,++library+  import: common+  exposed-modules:     Dep.Advice+                       Dep.Advice.Basic+                       Dep.SimpleAdvice+                       Dep.SimpleAdvice.Basic+                       Dep.ReaderAdvice+                       Dep.ReaderAdvice.Basic+                       Dep.IOAdvice+                       Dep.IOAdvice.Basic+  other-modules:       Dep.SimpleAdvice.Internal    +                        +  hs-source-dirs:      lib ++test-suite tests+  import:              common-tasty+  type:                exitcode-stdio-1.0+  main-is:             tests.hs++test-suite weird-advice-tests+  import:              common-tasty+  type:                exitcode-stdio-1.0+  main-is:             weird-advice-tests.hs+  build-depends:       +                       barbies            ^>= 2.0.2.0++test-suite simple-advice-tests+  import:              common-tasty+  type:                exitcode-stdio-1.0+  main-is:             simple-advice-tests.hs+  build-depends:       +                       barbies            ^>= 2.0.2.0++test-suite tests-has-conversion+  import:              common-tasty+  type:                exitcode-stdio-1.0+  main-is:             tests-has-conversion.hs+  build-depends:       aeson,+                       containers++test-suite synthetic-callstack-tests+  import:              common-tasty+  type:                exitcode-stdio-1.0+  main-is:             synthetic-callstack-tests.hs+  build-depends:       aeson,+                       containers,+                       microlens ^>= 0.4.12.0++-- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288+-- http://hackage.haskell.org/package/cabal-doctest+test-suite doctests+  import:              common-tests+  ghc-options:         -threaded+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             doctests.hs+  build-depends:       +                       doctest            ^>= 0.20+                       + -- 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,  ++

@@ -1,1019 +1,1019 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE GADTSyntax #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE UndecidableSuperClasses #-}
-{-# LANGUAGE BlockArguments #-}
-
--- |
---    This module provides the 'Advice' datatype, along for functions for creating,
---    manipulating, composing and applying values of that type.
---
---    'Advice's are type-preserving transformations on 'DepT'-effectful functions of
---    any number of arguments.
---
--- >>> :{
---    foo0 :: DepT NilEnv IO (Sum Int)
---    foo0 = pure (Sum 5)
---    foo1 :: Bool -> DepT NilEnv IO (Sum Int)
---    foo1 _ = foo0
---    foo2 :: Char -> Bool -> DepT NilEnv IO (Sum Int)
---    foo2 _ = foo1
--- :}
---
--- They work for @DepT@-actions of zero arguments:
---
--- >>> advise (fromSimple \_ -> printArgs stdout "foo0") foo0 `runDepT` NilEnv
--- foo0:
--- <BLANKLINE>
--- Sum {getSum = 5}
---
--- And for functions of one or more arguments, provided they end on a @DepT@-action:
---
--- >>> advise (fromSimple \_ -> printArgs stdout "foo1") foo1 False `runDepT` NilEnv
--- foo1: False
--- <BLANKLINE>
--- Sum {getSum = 5}
---
--- >>> advise (fromSimple \_ -> printArgs stdout "foo2") foo2 'd' False `runDepT` NilEnv
--- foo2: 'd' False
--- <BLANKLINE>
--- Sum {getSum = 5}
---
--- 'Advice's can also tweak the result value of functions:
---
--- >>> advise (fromSimple \_ -> returnMempty @Top) foo2 'd' False `runDepT` NilEnv
--- Sum {getSum = 0}
---
--- And they can be combined using @Advice@'s 'Monoid' instance before being
--- applied:
---
--- >>> advise (fromSimple \_ -> printArgs stdout "foo2" <> returnMempty) foo2 'd' False `runDepT` NilEnv
--- foo2: 'd' False
--- <BLANKLINE>
--- Sum {getSum = 0}
---
--- Although sometimes composition might require harmonizing the constraints
--- each 'Advice' places on the arguments, if they differ.
-module Dep.Advice
-  ( -- * The Advice type
-    Advice,
-
-    -- * Creating Advice values
-    makeAdvice,
-    makeArgsAdvice,
-    makeExecutionAdvice,
-
-    -- * Applying Advices
-    advise,
-
-    -- * Constraint helpers
-    -- $constrainthelpers
-    Ensure,
-
-    -- * Harmonizing Advice argument constraints
-    -- $restrict
-    restrictArgs,
-
-    -- * Invocation helpers
-    -- $invocation
-    runFinalDepT,
-    runFromEnv,
-    runFromDep,
-    -- askFinalDepT,
-    -- * Making functions see a different environment
-    deceive,
-
-    -- * Advising and deceiving entire records
-    -- $records
-    adviseRecord,
-    deceiveRecord,
-    -- * Plugging Has-based constructors
-    component,
-    --distributeDepT,
-
-    -- * Interfacing with "simple" advices
-    toSimple,
-    fromSimple,
-    fromSimple_,
-
-    -- * "sop-core" re-exports
-    -- $sop
-    Top,
-    And,
-    All,
-    NP (..),
-    I (..),
-    cfoldMap_NP,
-    Dict (..),
-  )
-where
-
-import Dep.Has
-import Dep.Env
-import Control.Monad.Dep
-import Control.Monad.Trans.Reader (ReaderT (..), withReaderT)
-import Data.Functor.Identity
-import Data.Kind
-import Data.List.NonEmpty qualified as N
-import Data.List.NonEmpty (NonEmpty)
-import Data.SOP
-import Data.SOP.Dict
-import Data.SOP.NP
-import Data.Typeable
-import GHC.Generics qualified as G
-import GHC.TypeLits
-import Data.Coerce
-import Data.Bifunctor (first)
-import Dep.SimpleAdvice.Internal qualified as SA
-
--- $setup
---
--- >>> :set -XTypeApplications
--- >>> :set -XStandaloneKindSignatures
--- >>> :set -XMultiParamTypeClasses
--- >>> :set -XFunctionalDependencies
--- >>> :set -XRankNTypes
--- >>> :set -XTypeOperators
--- >>> :set -XConstraintKinds
--- >>> :set -XNamedFieldPuns
--- >>> :set -XFlexibleContexts
--- >>> :set -XDerivingStrategies
--- >>> :set -XGeneralizedNewtypeDeriving
--- >>> :set -XDataKinds
--- >>> :set -XScopedTypeVariables
--- >>> :set -XDeriveGeneric
--- >>> :set -XImportQualifiedPost
--- >>> import Dep.Advice
--- >>> import Dep.SimpleAdvice.Basic (printArgs,returnMempty)
--- >>> import Control.Monad
--- >>> import Control.Monad.Dep
--- >>> import Control.Monad.Writer
--- >>> import Data.Kind
--- >>> import Data.SOP
--- >>> import Data.SOP.NP
--- >>> import Data.Monoid
--- >>> import System.IO
--- >>> import Data.IORef
--- >>> import GHC.Generics (Generic)
--- >>> import GHC.Generics qualified
-
--- | A generic transformation of 'DepT'-effectful functions with environment
--- @e_@, base monad @m@ and return type @r@,
--- provided the functions satisfy certain constraint @ca@
--- on all of their arguments.
---
--- 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'.
---
--- 'Advice's that don't care about the @ca@ constraint (because they don't
--- touch function arguments) can leave it polymorphic, and this facilitates
--- 'Advice' composition, but then the constraint must be given the catch-all
--- `Top` value (using a type application) at the moment of calling 'advise'.
---
--- See "Control.Monad.Dep.Advice.Basic" for examples.
-type Advice ::
-  (Type -> Constraint) ->
-  ((Type -> Type) -> Type) ->
-  (Type -> Type) ->
-  Type ->
-  Type
-data Advice (ca :: Type -> Constraint) (e_ :: (Type -> Type) -> Type) m r where
-  Advice ::
-    forall ca e_ m r.
-    ( forall as.
-      All ca as =>
-      NP I as ->
-      DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
-    ) ->
-    Advice ca e_ m r
-
--- |
---    '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
-  Advice outer <> Advice inner = Advice \args -> do
-    (tweakOuter, argsOuter) <- outer args
-    (tweakInner, argsInner) <- inner argsOuter
-    pure (tweakOuter . tweakInner, argsInner)
-
-instance Monad m => Monoid (Advice ca e_ m r) where
-  mappend = (<>)
-  mempty = Advice \args -> pure (id, args)
-
--- |
---    The most general way of constructing 'Advice's.
---
---    An 'Advice' is a function that transforms other functions in an 
---    arity-polymorphic way. It receives the arguments of the advised
---    function packed into an n-ary product 'NP', performs some 
---    effects based on them, and returns a potentially modified version of the 
---    arguments, along with a function for tweaking the execution of the
---    advised function.
---
--- >>> :{
---  doesNothing :: forall ca e_ m r. Monad m => Advice ca e_ m r
---  doesNothing = makeAdvice (\args -> pure (id,  args)) 
--- :}
---
---
-makeAdvice ::
-  forall ca e_ m r.
-  -- | The function that tweaks the arguments and the execution.
-  ( forall as.
-    All ca as =>
-    NP I as ->
-    DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
-  ) ->
-  Advice ca e_ m r
-makeAdvice = Advice
-
--- |
---    Create an advice which only tweaks and/or analyzes the function arguments.
---
--- >>> :{
---  doesNothing :: forall ca e_ m r. Monad m => Advice ca e_ m r
---  doesNothing = makeArgsAdvice pure
--- :}
-makeArgsAdvice ::
-  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)
-  ) ->
-  Advice ca e_ m r
-makeArgsAdvice tweakArgs =
-  makeAdvice $ \args -> do
-    args' <- tweakArgs args
-    pure (id, args')
-
--- |
---    Create an advice which only tweaks the execution of the final monadic action.
---
--- >>> :{
---  doesNothing :: forall ca e_ m r. Monad m => Advice ca e_ m r
---  doesNothing = makeExecutionAdvice id
--- :}
-makeExecutionAdvice ::
-  forall ca e_ m r.
-  Applicative m =>
-  -- | The function that tweaks the execution.
-  ( DepT e_ m r ->
-    DepT e_ m r
-  ) ->
-  Advice ca e_ m r
-makeExecutionAdvice tweakExecution = makeAdvice \args -> pure (tweakExecution, args)
-
-data Pair a b = Pair !a !b
-
--- |
--- 'Ensure' is a helper for lifting typeclass definitions of the form:
---
--- >>> :{
---  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:
---
--- >>> :{
---  requiresLogger :: forall e_ m r. (Ensure HasLogger e_ m, Monad m) => Advice Show e_ m r
---  requiresLogger = mempty
---  :}
---
--- Why is it necessary? Two-place @HasX@-style constraints receive the \"fully
--- applied\" type of the record-of-functions. That is: @NilEnv IO@ instead of
--- simply @NilEnv@. This allows them to also work with monomorphic environments
--- (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@.
--- 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 (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.
---
--- >>> :{
---  foo :: Int -> DepT NilEnv IO String
---  foo _ = pure "foo"
---  advisedFoo = advise (fromSimple \_ -> printArgs stdout "Foo args: ") foo
--- :}
---
--- __/TYPE APPLICATION REQUIRED!/__ If the @ca@ constraint of the 'Advice' remains polymorphic,
--- it must be supplied by means of a type application:
---
--- >>> :{
---  bar :: Int -> DepT NilEnv IO String
---  bar _ = pure "bar"
---  advisedBar1 = advise (fromSimple \_ -> returnMempty @Top) bar
---  advisedBar2 = advise @Top (fromSimple \_ -> returnMempty) bar
--- :}
-advise ::
-  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 ->
-  -- | A function to be adviced.
-  advisee ->
-  advisee
-advise (Advice f) advisee = do
-  let uncurried = multiuncurry @as @e_ @m @r advisee
-      uncurried' args = do
-        (tweakExecution, args') <- f args
-        tweakExecution (uncurried args')
-   in multicurry @as @e_ @m @r uncurried'
-
-type Multicurryable ::
-  [Type] ->
-  ((Type -> Type) -> Type) ->
-  (Type -> Type) ->
-  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
-  _askFinalDepT :: (e_ (DepT e_ m) -> m curried) -> curried
-
-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
-  _askFinalDepT f = do
-    env <- ask
-    r <- lift (f env)
-    r
-
-instance (Functor m, 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)
-  _askFinalDepT f = 
-    let switcheroo action a = fmap ($ a) action
-     in _askFinalDepT @as @e_ @m @r . flip (fmap switcheroo f)
-
--- | Given a base monad @m@ action that gets hold of the 'DepT' environment, run
--- the 'DepT' transformer at the tip of a curried function.
---
--- >>> :{
---  foo :: Int -> Int -> Int -> DepT NilEnv IO ()
---  foo _ _ _ = pure ()
--- :}
---
---  >>> runFinalDepT (pure NilEnv) foo 1 2 3 :: IO ()
-runFinalDepT ::
-  forall as e_ m r curried.
-  Multicurryable as e_ m r curried =>
-  -- | action that gets hold of the environment
-  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
-runFinalDepT producer extractor = _runFromEnv producer (const extractor)
-
-askFinalDepT ::
-  forall as e_ m r curried. 
-  Multicurryable as e_ m r curried =>
-  (e_ (DepT e_ m) -> m curried) -> curried
-askFinalDepT = _askFinalDepT @as @e_ @m @r
-
--- | Given a base monad @m@ action that gets hold of the 'DepT' environment,
--- and a function capable of extracting a curried function from the
--- environment, run the 'DepT' transformer at the tip of the resulting curried
--- function.
---
--- Why put the environment behind the @m@ action? Well, since getting to the
--- end of the curried function takes some work, it's a good idea to have some
--- flexibility once we arrive there. For example, the environment could be
--- stored in a "Data.IORef" and change in response to events, perhaps with
--- advices being added or removed.
---
--- >>> :{
---   type MutableEnv :: (Type -> Type) -> Type
---   data MutableEnv m = MutableEnv { _foo :: Int -> m (Sum Int) }
---   :}
---
--- >>> :{
---   do envRef <- newIORef (MutableEnv (pure . Sum))
---      let foo' = runFromEnv (readIORef envRef) _foo
---      do r <- foo' 7
---         print r
---      modifyIORef envRef (\e -> e { _foo = advise @Top (fromSimple \_ -> returnMempty) (_foo e) })
---      do r <- foo' 7
---         print r
--- :}
--- Sum {getSum = 7}
--- Sum {getSum = 0}
-runFromEnv ::
-  forall as e_ m r curried.
-  Multicurryable as e_ m r curried =>
-  -- | action that gets hold of the environment
-  m (e_ (DepT e_ m)) ->
-  -- | gets a function from the environment with effects in 'DepT'
-  (e_ (DepT e_ m) -> curried) ->
-  -- | a new function with effects in the base monad
-  DownToBaseMonad as e_ m r curried
-runFromEnv = _runFromEnv
-
--- | Like 'runFromEnv', but the function to run is extracted from a dependency
--- @dep@ which is found using 'Has'. The selector should be concrete enough to
--- identify @dep@ in the environment.
-runFromDep ::
-  forall dep as e_ m r curried.
-  (Multicurryable as e_ m r curried, Has dep (DepT e_ m) (e_ (DepT e_ m))) =>
-  -- | action that gets hold of the environment
-  m (e_ (DepT e_ m)) ->
-  -- | selector that gets a function from a dependency found using 'Has'
-  (dep (DepT e_ m) -> curried) ->
-  -- | a new function with effects in the base monad
-  DownToBaseMonad as e_ m r curried
-runFromDep envAction member = _runFromEnv envAction (member . dep)
-
--- $restrict
---
---    'Advice' values can be composed using the 'Monoid' instance, but only if
---    they have the same type parameters. It's unfortunate that—unlike with
---    normal function constraints—the @ca@ constraints of an 'Advice' aren't
---    automatically "collected" during composition.
---
---    Instead, we need to harmonize the @ca@ constraints of each 'Advice' by
---    turning them into the combination of all constraints. 'restrictArgs'
---    helps with that.
---
---    'restrictArgs' takes as parameter value-level "\evidence\" that one
---    constraint implies another. But how to construct such evidence? By using
---    the 'Dict' GADT, more precisely the deceptively simple-looking term
---    @\\Dict -> Dict@. That function "absorbs" some constraint present in the
---    ambient context and re-packages it a a new constraint that is implied by
---    the former. We can't rely on type inference here; we need to provide
---    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) e_ m r
---  stricterPrintArgs = restrictArgs (\Dict -> Dict) (fromSimple \_ -> printArgs stdout "foo")
--- :}
---
---    or with a type application to 'restrictArgs':
---
--- >>> stricterPrintArgs = restrictArgs @(Show `And` Eq `And` Ord) (\Dict -> Dict) (fromSimple \_ -> printArgs stdout "foo")
-
--- | Makes the constraint on the arguments more restrictive.
-restrictArgs ::
-  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) ->
-  -- | Advice with less restrictive constraint on the args.
-  Advice less e_ m r ->
-  -- | Advice with more restrictive constraint on the args.
-  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
--- come pre-packaged and having a type signature.
--- We arent' so sure about having a signature for a whole composed Advice,
--- because the composition might be done
--- on the fly, while constructing a record, without a top-level binding with a
--- type signature.  This seems to favor putting "more" first.
-restrictArgs evidence (Advice advice) = Advice \args ->
-    let advice' :: forall as. All more as => NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)
-        advice' args' =
-            case Data.SOP.Dict.mapAll @more @less evidence of
-               f -> case f (Dict @(All more) @as) of
-                        Dict -> advice args'
-     in advice' args
-
---
-type Gullible ::
-  [Type] ->
-  Type ->
-  ((Type -> Type) -> Type) ->
-  (Type -> Type) ->
-  Type ->
-  Type ->
-  Constraint
-class Multicurryable as e_ m r curried => Gullible as e e_ m r curried where
-  type NewtypedEnv as e e_ m r curried :: Type
-  _deceive :: (e_ (DepT e_ m) -> e) -> NewtypedEnv as e e_ m r curried -> curried
-
-instance Monad m => Gullible '[] e e_ m r (DepT e_ m r) where
-  type NewtypedEnv '[] e e_ m r (DepT e_ m r) = ReaderT e m r
-  _deceive f action = DepT (withReaderT f action)
-
-instance (Functor m, Gullible as e e_ m r curried) => Gullible (a ': as) e e_ m r (a -> curried) where
-  type NewtypedEnv (a ': as) e e_ m r (a -> curried) = a -> NewtypedEnv as e e_ m r curried
-  _deceive f g a = deceive @as @e @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 e e_ m r curried.
-  Gullible as e e_ m r curried =>
-  -- | The newtype constructor that masks the \"true\" environment.
-  (e_ (DepT e_ m) -> e) ->
-  -- | A function to be deceived. It must be polymorphic over 'Control.Monad.Dep.MonadDep'.
-  NewtypedEnv as e e_ m r curried ->
-  -- | The deceived function, that has effects in 'DepT'.
-  curried
-deceive = _deceive
-
--- deceving *all* fields of a record
---
---
-type GullibleRecord :: Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> ((Type -> Type) -> Type) -> Constraint
-class GullibleRecord e e_ m gullible where
-  _deceiveRecord :: (e_ (DepT e_ m) -> e) -> gullible (ReaderT e m) -> gullible (DepT e_ m)
-
--- https://gitlab.haskell.org/ghc/ghc/-/issues/13952
-type GullibleProduct :: Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> (k -> Type) -> (k -> Type) -> Constraint
-class GullibleProduct e e_ m gullible_ deceived_ | e e_ m deceived_ -> gullible_ where
-  _deceiveProduct :: (e_ (DepT e_ m) -> e) -> gullible_ k -> deceived_ k
-
-instance
-  ( GullibleProduct e e_ m gullible_left deceived_left,
-    GullibleProduct e e_ m gullible_right deceived_right
-  ) =>
-  GullibleProduct e e_ m (gullible_left G.:*: gullible_right) (deceived_left G.:*: deceived_right)
-  where
-  _deceiveProduct f (gullible_left G.:*: gullible_right) = _deceiveProduct @_ @e @e_ @m f gullible_left G.:*: _deceiveProduct @_ @e @e_ @m f gullible_right
-
-data RecordComponent
-  = Terminal
-  | IWrapped
-  | Recurse
-
-type DiscriminateGullibleComponent :: Type -> RecordComponent
-type family DiscriminateGullibleComponent c where
-  DiscriminateGullibleComponent (a -> b) = Terminal
-  DiscriminateGullibleComponent (ReaderT e m x) = Terminal
-  DiscriminateGullibleComponent (Identity _) = IWrapped
-  DiscriminateGullibleComponent (I _) = IWrapped
-  DiscriminateGullibleComponent _ = Recurse
-
-type GullibleComponent :: RecordComponent -> Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> Type -> Type -> Constraint
-class GullibleComponent component_type e e_ m gullible deceived | e e_ m deceived -> gullible where
-  _deceiveComponent :: (e_ (DepT e_ m) -> e) -> gullible -> deceived
-
-instance
-  (Gullible as e e_ m r deceived, NewtypedEnv as e e_ m r deceived ~ gullible) =>
-  GullibleComponent Terminal e e_ m gullible deceived
-  where
-  _deceiveComponent f gullible = deceive @as @e @_ @m @r f gullible
-
-instance
-  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>
-  GullibleComponent IWrapped e e_ m (Identity gullible) (Identity deceived)
-  where
-  _deceiveComponent f (Identity gullible) = Identity (_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m f gullible)
-
-instance
-  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>
-  GullibleComponent IWrapped e e_ m (I gullible) (I deceived)
-  where
-  _deceiveComponent f (I gullible) = I (_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m f gullible)
-
-instance
-  GullibleRecord e e_ m gullible =>
-  GullibleComponent Recurse e e_ m (gullible (ReaderT e m)) (gullible (DepT e_ m))
-  where
-  _deceiveComponent f gullible = _deceiveRecord @e @e_ @m f gullible
-
-instance
-  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>
-  GullibleProduct e e_ m (G.S1 x (G.Rec0 gullible)) (G.S1 x (G.Rec0 deceived))
-  where
-  _deceiveProduct f (G.M1 (G.K1 gullible)) = G.M1 (G.K1 (_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m f gullible))
-
-instance
-  ( G.Generic (gullible (ReaderT e m)),
-    G.Generic (gullible (DepT e_ m)),
-    G.Rep (gullible (ReaderT e m)) ~ G.D1 x (G.C1 y gullible_),
-    G.Rep (gullible (DepT e_ m)) ~ G.D1 x (G.C1 y deceived_),
-    GullibleProduct e e_ m gullible_ deceived_
-  ) =>
-  GullibleRecord e e_ m gullible
-  where
-  _deceiveRecord f gullible =
-    let G.M1 (G.M1 gullible_) = G.from gullible
-        deceived_ = _deceiveProduct @_ @e @e_ @m f gullible_
-     in G.to (G.M1 (G.M1 deceived_))
-
--- | Makes an entire record-of-functions see a different version of the global environment record, a version that might have different @HasX@ instances.
---
--- 'deceiveRecord' must be applied before 'adviseRecord'.
-deceiveRecord ::
-  forall e e_ m gullible.
-  GullibleRecord e e_ m gullible =>
-  -- | The newtype constructor that masks the \"true\" environment.
-  (e_ (DepT e_ m) -> e) ->
-  -- | The record to deceive recursively. The monad parameter must be left polymorphic over @MonadDep@, so that it can unify with `ReaderT`.
-  gullible (ReaderT e m) ->
-  -- | The deceived record.
-  gullible (DepT e_ m)
-deceiveRecord = _deceiveRecord @e @e_ @m @gullible
-
-
--- | Given a constructor that returns a record-of-functions with effects in 'DepT',
--- produce a record in which the member functions 'ask' for the environment themselves.
---
--- You must have a sufficiently polymorphic constructor—both in the monad and
--- in the environment—to invoke this function.
---
--- 'component' lets you plug simple component constructors 
--- into a 'DepT'-based environment.
---
--- Compare with 'Control.Monad.Dep.Env.constructor' from "Control.Monad.Dep.Env", which 
--- is intended to be used with 'Control.Monad.Dep.Env.fixEnv'-based environments.
-component 
-    :: forall e_ m record . (Applicative m, DistributiveRecord e_ m record) => 
-    -- | constructor which takes the environment as a positional parameter.
-    (e_ (DepT e_ m) -> record (DepT e_ m)) ->
-    -- | component whose methods get the environment by 'ask'ing.
-    record (DepT e_ m)
-component f = _distribute @e_ @m (pure . f)
-
-
-
-type DistributiveRecord :: ((Type -> Type) -> Type) -> (Type -> Type) -> ((Type -> Type) -> Type) -> Constraint
-class DistributiveRecord e_ m record where
-    _distribute :: (e_ (DepT e_ m) -> m (record (DepT e_ m))) -> record (DepT e_ m)
-
-type DistributiveProduct :: ((Type -> Type) -> Type) -> (Type -> Type) -> (k -> Type) -> Constraint
-class DistributiveProduct e_ m product where
-    _distributeProduct :: (e_ (DepT e_ m) -> m (product k)) -> product k
-
-instance
-  ( G.Generic (advised (DepT e_ m)),
-    G.Rep (advised (DepT e_ m)) ~ G.D1 x (G.C1 y advised_),
-    DistributiveProduct e_ m advised_,
-    Functor m
-  ) =>
-  DistributiveRecord e_ m advised
-  where
-  _distribute f =
-    let advised_ = _distributeProduct @_ @e_ @m (fmap (fmap (G.unM1 . G.unM1 . G.from)) f)
-     in G.to (G.M1 (G.M1 advised_))
-
-instance
-  ( DistributiveProduct e_ m advised_left,
-    DistributiveProduct e_ m advised_right,
-    Functor m
-  ) =>
-  DistributiveProduct e_ m (advised_left G.:*: advised_right)
-  where
-  _distributeProduct f  = 
-      _distributeProduct @_ @e_ @m (fmap (fmap (\(l G.:*: _) -> l)) f) 
-      G.:*: 
-      _distributeProduct @_ @e_ @m (fmap (fmap (\(_ G.:*: r) -> r)) f) 
-
-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
-  ) =>
-  DistributiveSubcomponent Terminal e_ m advised
-  where
-  _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
---
---
-type AdvisedRecord :: (Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> Constraint
-class AdvisedRecord ca e_ m cr advised where
-  _adviseRecord :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r) -> advised (DepT e_ m) -> advised (DepT e_ m)
-
-type AdvisedProduct :: (Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> (Type -> Constraint) -> (k -> Type) -> Constraint
-class AdvisedProduct ca e_ m cr advised_ where
-  _adviseProduct :: TypeRep -> [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r) -> advised_ k -> advised_ k
-
-instance
-  ( G.Generic (advised (DepT e_ m)),
-    -- G.Rep (advised (DepT e_ m)) ~ G.D1 ('G.MetaData name mod p nt) (G.C1 y advised_),
-    G.Rep (advised (DepT e_ m)) ~ G.D1 x (G.C1 y advised_),
-    Typeable advised,
-    AdvisedProduct ca e_ m cr advised_
-  ) =>
-  AdvisedRecord ca e_ m cr advised
-  where
-  _adviseRecord acc f unadvised =
-    let G.M1 (G.M1 unadvised_) = G.from unadvised
-        advised_ = _adviseProduct @_ @ca @e_ @m @cr (typeRep (Proxy @advised)) acc f unadvised_
-     in G.to (G.M1 (G.M1 advised_))
-
-instance
-  ( AdvisedProduct ca e_ m cr advised_left,
-    AdvisedProduct ca e_ m cr advised_right
-  ) =>
-  AdvisedProduct ca e_ m cr (advised_left G.:*: advised_right)
-  where
-  _adviseProduct tr acc f (unadvised_left G.:*: unadvised_right) = _adviseProduct @_ @ca @e_ @m @cr tr acc f unadvised_left G.:*: _adviseProduct @_ @ca @e_ @m @cr tr acc f unadvised_right
-
-type DiscriminateAdvisedComponent :: Type -> RecordComponent
-type family DiscriminateAdvisedComponent c where
-  DiscriminateAdvisedComponent (a -> b) = Terminal
-  DiscriminateAdvisedComponent (DepT e_ m x) = Terminal
-  DiscriminateAdvisedComponent (Identity _) = IWrapped
-  DiscriminateAdvisedComponent (I _) = IWrapped
-  DiscriminateAdvisedComponent _ = Recurse
-
-type AdvisedComponent :: RecordComponent -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> (Type -> Constraint) -> Type -> Constraint
-class AdvisedComponent component_type ca e_ m cr advised where
-  _adviseComponent :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r) -> advised -> advised
-
-instance
-  ( AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised,
-    KnownSymbol fieldName
-  ) =>
-  AdvisedProduct ca e_ m cr (G.S1 ( 'G.MetaSel ( 'Just fieldName) su ss ds) (G.Rec0 advised))
-  where
-  _adviseProduct tr acc f (G.M1 (G.K1 advised)) =
-    let acc' = (tr, symbolVal (Proxy @fieldName)) : acc
-     in G.M1 (G.K1 (_adviseComponent @(DiscriminateAdvisedComponent advised) @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
-  _adviseComponent acc f advised = advise @ca @e_ @m (f (N.fromList acc)) advised
-
-instance
-  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised =>
-  AdvisedComponent IWrapped ca e_ m cr (Identity advised)
-  where
-  _adviseComponent acc f (Identity advised) = Identity (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e_ @m @cr acc f advised)
-
-instance
-  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised =>
-  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.
---
--- The function that builds the advice receives a list of tuples @(TypeRep, String)@
--- which represent the record types and fields names we have
--- traversed until arriving at the advised function. This info can be useful for
--- logging advices. It's a list instead of a single tuple because
--- 'adviseRecord' works recursively. The elements come innermost-first.
---
--- __/TYPE APPLICATION REQUIRED!/__ The @ca@ constraint on function arguments
--- and the @cr@ constraint on the result type must be supplied by means of a
--- type application. Supply 'Top' if no constraint is required.
-adviseRecord ::
-  forall ca cr e_ m advised.
-  AdvisedRecord ca e_ m cr advised =>
-  -- | The advice to apply.
-  (forall r . cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r) ->
-  -- | The record to advise recursively.
-  advised (DepT e_ m) ->
-  -- | The advised record.
-  advised (DepT e_ m)
-adviseRecord = _adviseRecord @ca @e_ @m @cr []
-
--- $records
---
--- 'adviseRecord' and 'deceiveRecord' are versions of 'advise' and 'deceive' that, instead of working on bare
--- functions, transform entire records-of-functions in one go. They also work
--- with newtypes containing a single function. The records must derive 'GHC.Generics.Generic'.
---
--- Useful with the \"wrapped\" style of components facilitated by @Control.Monad.Dep.Has@.
---
--- >>> :{
---   type Logger :: (Type -> Type) -> Type
---   newtype Logger d = Logger {log :: String -> d ()} deriving Generic
---   type Repository :: (Type -> Type) -> Type
---   data Repository d = Repository
---     { select :: String -> d [Int],
---       insert :: [Int] -> d ()
---     } deriving Generic
---   type Controller :: (Type -> Type) -> Type
---   newtype Controller d = Controller {serve :: Int -> d String} deriving Generic
---   type Env :: (Type -> Type) -> Type
---   data Env m = Env
---     { logger :: Logger m,
---       repository :: Repository m,
---       controller :: Controller m
---     }
---   newtype Wraps x = Wraps x
---   env :: Env (DepT Env (Writer ()))
---   env =
---     let logger = Logger \_ -> pure ()
---         repository =
---           adviseRecord @Top @Top mempty $
---           deceiveRecord Wraps $
---           Repository {select = \_ -> pure [], insert = \_ -> pure ()}
---         controller =
---           adviseRecord @Top @Top mempty $
---           deceiveRecord Wraps $
---           Controller \_ -> pure "view"
---      in Env {logger, repository, controller}
--- :}
-
--- $sop
--- Some useful definitions re-exported the from \"sop-core\" package.
---
--- 'NP' is an n-ary product used to represent the arguments of advised functions.
---
--- 'I' is an identity functor. The arguments processed by an 'Advice' come wrapped in it.
---
--- 'cfoldMap_NP' is useful to construct homogeneous lists out of the 'NP' product, for example:
---
--- >>> cfoldMap_NP (Proxy @Show) (\(I a) -> [show a]) (I False :* I (1::Int) :* Nil)
--- ["False","1"]
-
--- $constraints
---
--- Some useful definitions re-exported the from \"constraints\" package.
---
--- 'Dict' and '(:-)' are GADTs used to capture and transform constraints. Used in the 'restrictArgs' function.
-
--- $constrainthelpers
---
--- To help with the constraint @ca@ that parameterizes 'Advice', this library re-exports the following helpers from \"sop-core\":
---
--- * 'Top' is the \"always satisfied\" constraint, useful when whe don't want to require anything specific in @ca@.
---
--- * 'And' combines two constraints so that an 'Advice' can request them both, for example @Show \`And\` Eq@.
---
--- Also, the 'All' constraint says that some constraint is satisfied by all the
--- components of an 'NP' product. It's in scope when processing the function
--- arguments inside an 'Advice'.
-
--- $invocation
--- These functions are helpers for running 'DepT' computations, beyond what 'runDepT' provides.
---
--- They aren't directly related to 'Advice's, but they require some of the same machinery, and that's why they are here.
-
--- | An advice that is polymorphic on the environment (allowing it to unify
--- with 'Control.Monad.Dep.NilEnv') can be converted to a "simple" 'Control.Monad.Dep.SimpleAdvice.Advice' that doesn't require 'Control.Monad.Dep.DepT' at all. 
-toSimple :: Monad m => Advice ca NilEnv m r -> SA.Advice ca m r
-toSimple (Advice f) = SA.Advice \args -> lift do
-    (withExecution, args') <- f args `runDepT` NilEnv
-    let withExecution' = lift . flip runDepT NilEnv . withExecution . lift . SA.runAspectT
-    pure (withExecution', args')
-
--- | Convert a simple 'Control.Monad.Dep.SimpleAdvice.Advice' whose monad unifies with `DepT e_ m` into an 'Advice'.
-fromSimple :: forall ca e_ m r. Monad m => (e_ (DepT e_ m) -> SA.Advice ca (DepT e_ m) r) -> Advice ca e_ m r
-fromSimple makeAdvice = Advice \args -> do
-    env <- ask
-    case makeAdvice env of
-        SA.Advice f -> do
-            let SA.AspectT argsAction = f args
-            (tweakExecution, args') <- argsAction
-            pure (coerce tweakExecution, args')
-
--- | Like 'fromSimple', but for 'Control.Monad.Dep.SimpleAdvice.Advice's that don't use the environment.
-fromSimple_ :: forall ca e_ m r. Monad m => SA.Advice ca (DepT e_ m) r -> Advice ca e_ m r
-fromSimple_ advice = fromSimple \_ -> advice
-
+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE BlockArguments #-}++-- |+--    This module provides the 'Advice' datatype, along for functions for creating,+--    manipulating, composing and applying values of that type.+--+--    'Advice's are type-preserving transformations on 'DepT'-effectful functions of+--    any number of arguments.+--+-- >>> :{+--    foo0 :: DepT NilEnv IO (Sum Int)+--    foo0 = pure (Sum 5)+--    foo1 :: Bool -> DepT NilEnv IO (Sum Int)+--    foo1 _ = foo0+--    foo2 :: Char -> Bool -> DepT NilEnv IO (Sum Int)+--    foo2 _ = foo1+-- :}+--+-- They work for @DepT@-actions of zero arguments:+--+-- >>> advise (fromSimple \_ -> printArgs stdout "foo0") foo0 `runDepT` NilEnv+-- foo0:+-- <BLANKLINE>+-- Sum {getSum = 5}+--+-- And for functions of one or more arguments, provided they end on a @DepT@-action:+--+-- >>> advise (fromSimple \_ -> printArgs stdout "foo1") foo1 False `runDepT` NilEnv+-- foo1: False+-- <BLANKLINE>+-- Sum {getSum = 5}+--+-- >>> advise (fromSimple \_ -> printArgs stdout "foo2") foo2 'd' False `runDepT` NilEnv+-- foo2: 'd' False+-- <BLANKLINE>+-- Sum {getSum = 5}+--+-- 'Advice's can also tweak the result value of functions:+--+-- >>> advise (fromSimple \_ -> returnMempty @Top) foo2 'd' False `runDepT` NilEnv+-- Sum {getSum = 0}+--+-- And they can be combined using @Advice@'s 'Monoid' instance before being+-- applied:+--+-- >>> advise (fromSimple \_ -> printArgs stdout "foo2" <> returnMempty) foo2 'd' False `runDepT` NilEnv+-- foo2: 'd' False+-- <BLANKLINE>+-- Sum {getSum = 0}+--+-- Although sometimes composition might require harmonizing the constraints+-- each 'Advice' places on the arguments, if they differ.+module Dep.Advice+  ( -- * The Advice type+    Advice,++    -- * Creating Advice values+    makeAdvice,+    makeArgsAdvice,+    makeExecutionAdvice,++    -- * Applying Advices+    advise,++    -- * Constraint helpers+    -- $constrainthelpers+    Ensure,++    -- * Harmonizing Advice argument constraints+    -- $restrict+    restrictArgs,++    -- * Invocation helpers+    -- $invocation+    runFinalDepT,+    runFromEnv,+    runFromDep,+    -- askFinalDepT,+    -- * Making functions see a different environment+    deceive,++    -- * Advising and deceiving entire records+    -- $records+    adviseRecord,+    deceiveRecord,+    -- * Plugging Has-based constructors+    component,+    --distributeDepT,++    -- * Interfacing with "simple" advices+    toSimple,+    fromSimple,+    fromSimple_,++    -- * "sop-core" re-exports+    -- $sop+    Top,+    And,+    All,+    NP (..),+    I (..),+    cfoldMap_NP,+    Dict (..),+  )+where++import Dep.Has+import Dep.Env+import Control.Monad.Dep+import Control.Monad.Trans.Reader (ReaderT (..), withReaderT)+import Data.Functor.Identity+import Data.Kind+import Data.List.NonEmpty qualified as N+import Data.List.NonEmpty (NonEmpty)+import Data.SOP+import Data.SOP.Dict+import Data.SOP.NP+import Data.Typeable+import GHC.Generics qualified as G+import GHC.TypeLits+import Data.Coerce+import Data.Bifunctor (first)+import Dep.SimpleAdvice.Internal qualified as SA++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XStandaloneKindSignatures+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XFunctionalDependencies+-- >>> :set -XRankNTypes+-- >>> :set -XTypeOperators+-- >>> :set -XConstraintKinds+-- >>> :set -XNamedFieldPuns+-- >>> :set -XFlexibleContexts+-- >>> :set -XDerivingStrategies+-- >>> :set -XGeneralizedNewtypeDeriving+-- >>> :set -XDataKinds+-- >>> :set -XScopedTypeVariables+-- >>> :set -XDeriveGeneric+-- >>> :set -XImportQualifiedPost+-- >>> import Dep.Advice+-- >>> import Dep.SimpleAdvice.Basic (printArgs,returnMempty)+-- >>> import Control.Monad+-- >>> import Control.Monad.Dep+-- >>> import Control.Monad.Writer+-- >>> import Data.Kind+-- >>> import Data.SOP+-- >>> import Data.SOP.NP+-- >>> import Data.Monoid+-- >>> import System.IO+-- >>> import Data.IORef+-- >>> import GHC.Generics (Generic)+-- >>> import GHC.Generics qualified++-- | A generic transformation of 'DepT'-effectful functions with environment+-- @e_@, base monad @m@ and return type @r@,+-- provided the functions satisfy certain constraint @ca@+-- on all of their arguments.+--+-- 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'.+--+-- 'Advice's that don't care about the @ca@ constraint (because they don't+-- touch function arguments) can leave it polymorphic, and this facilitates+-- 'Advice' composition, but then the constraint must be given the catch-all+-- `Top` value (using a type application) at the moment of calling 'advise'.+--+-- See "Dep.Advice.Basic" for examples.+type Advice ::+  (Type -> Constraint) ->+  ((Type -> Type) -> Type) ->+  (Type -> Type) ->+  Type ->+  Type+data Advice (ca :: Type -> Constraint) (e_ :: (Type -> Type) -> Type) m r where+  Advice ::+    forall ca e_ m r.+    ( forall as.+      All ca as =>+      NP I as ->+      DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)+    ) ->+    Advice ca e_ m r++-- |+--    '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+  Advice outer <> Advice inner = Advice \args -> do+    (tweakOuter, argsOuter) <- outer args+    (tweakInner, argsInner) <- inner argsOuter+    pure (tweakOuter . tweakInner, argsInner)++instance Monad m => Monoid (Advice ca e_ m r) where+  mappend = (<>)+  mempty = Advice \args -> pure (id, args)++-- |+--    The most general way of constructing 'Advice's.+--+--    An 'Advice' is a function that transforms other functions in an +--    arity-polymorphic way. It receives the arguments of the advised+--    function packed into an n-ary product 'NP', performs some +--    effects based on them, and returns a potentially modified version of the +--    arguments, along with a function for tweaking the execution of the+--    advised function.+--+-- >>> :{+--  doesNothing :: forall ca e_ m r. Monad m => Advice ca e_ m r+--  doesNothing = makeAdvice (\args -> pure (id,  args)) +-- :}+--+--+makeAdvice ::+  forall ca e_ m r.+  -- | The function that tweaks the arguments and the execution.+  ( forall as.+    All ca as =>+    NP I as ->+    DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)+  ) ->+  Advice ca e_ m r+makeAdvice = Advice++-- |+--    Create an advice which only tweaks and/or analyzes the function arguments.+--+-- >>> :{+--  doesNothing :: forall ca e_ m r. Monad m => Advice ca e_ m r+--  doesNothing = makeArgsAdvice pure+-- :}+makeArgsAdvice ::+  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)+  ) ->+  Advice ca e_ m r+makeArgsAdvice tweakArgs =+  makeAdvice $ \args -> do+    args' <- tweakArgs args+    pure (id, args')++-- |+--    Create an advice which only tweaks the execution of the final monadic action.+--+-- >>> :{+--  doesNothing :: forall ca e_ m r. Monad m => Advice ca e_ m r+--  doesNothing = makeExecutionAdvice id+-- :}+makeExecutionAdvice ::+  forall ca e_ m r.+  Applicative m =>+  -- | The function that tweaks the execution.+  ( DepT e_ m r ->+    DepT e_ m r+  ) ->+  Advice ca e_ m r+makeExecutionAdvice tweakExecution = makeAdvice \args -> pure (tweakExecution, args)++data Pair a b = Pair !a !b++-- |+-- 'Ensure' is a helper for lifting typeclass definitions of the form:+--+-- >>> :{+--  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:+--+-- >>> :{+--  requiresLogger :: forall e_ m r. (Ensure HasLogger e_ m, Monad m) => Advice Show e_ m r+--  requiresLogger = mempty+--  :}+--+-- Why is it necessary? Two-place @HasX@-style constraints receive the \"fully+-- applied\" type of the record-of-functions. That is: @NilEnv IO@ instead of+-- simply @NilEnv@. This allows them to also work with monomorphic environments+-- (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@.+-- 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 (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.+--+-- >>> :{+--  foo :: Int -> DepT NilEnv IO String+--  foo _ = pure "foo"+--  advisedFoo = advise (fromSimple \_ -> printArgs stdout "Foo args: ") foo+-- :}+--+-- __/TYPE APPLICATION REQUIRED!/__ If the @ca@ constraint of the 'Advice' remains polymorphic,+-- it must be supplied by means of a type application:+--+-- >>> :{+--  bar :: Int -> DepT NilEnv IO String+--  bar _ = pure "bar"+--  advisedBar1 = advise (fromSimple \_ -> returnMempty @Top) bar+--  advisedBar2 = advise @Top (fromSimple \_ -> returnMempty) bar+-- :}+advise ::+  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 ->+  -- | A function to be adviced.+  advisee ->+  advisee+advise (Advice f) advisee = do+  let uncurried = multiuncurry @as @e_ @m @r advisee+      uncurried' args = do+        (tweakExecution, args') <- f args+        tweakExecution (uncurried args')+   in multicurry @as @e_ @m @r uncurried'++type Multicurryable ::+  [Type] ->+  ((Type -> Type) -> Type) ->+  (Type -> Type) ->+  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+  _askFinalDepT :: (e_ (DepT e_ m) -> m curried) -> curried++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+  _askFinalDepT f = do+    env <- ask+    r <- lift (f env)+    r++instance (Functor m, 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)+  _askFinalDepT f = +    let switcheroo action a = fmap ($ a) action+     in _askFinalDepT @as @e_ @m @r . flip (fmap switcheroo f)++-- | Given a base monad @m@ action that gets hold of the 'DepT' environment, run+-- the 'DepT' transformer at the tip of a curried function.+--+-- >>> :{+--  foo :: Int -> Int -> Int -> DepT NilEnv IO ()+--  foo _ _ _ = pure ()+-- :}+--+--  >>> runFinalDepT (pure NilEnv) foo 1 2 3 :: IO ()+runFinalDepT ::+  forall as e_ m r curried.+  Multicurryable as e_ m r curried =>+  -- | action that gets hold of the environment+  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+runFinalDepT producer extractor = _runFromEnv producer (const extractor)++askFinalDepT ::+  forall as e_ m r curried. +  Multicurryable as e_ m r curried =>+  (e_ (DepT e_ m) -> m curried) -> curried+askFinalDepT = _askFinalDepT @as @e_ @m @r++-- | Given a base monad @m@ action that gets hold of the 'DepT' environment,+-- and a function capable of extracting a curried function from the+-- environment, run the 'DepT' transformer at the tip of the resulting curried+-- function.+--+-- Why put the environment behind the @m@ action? Well, since getting to the+-- end of the curried function takes some work, it's a good idea to have some+-- flexibility once we arrive there. For example, the environment could be+-- stored in a "Data.IORef" and change in response to events, perhaps with+-- advices being added or removed.+--+-- >>> :{+--   type MutableEnv :: (Type -> Type) -> Type+--   data MutableEnv m = MutableEnv { _foo :: Int -> m (Sum Int) }+--   :}+--+-- >>> :{+--   do envRef <- newIORef (MutableEnv (pure . Sum))+--      let foo' = runFromEnv (readIORef envRef) _foo+--      do r <- foo' 7+--         print r+--      modifyIORef envRef (\e -> e { _foo = advise @Top (fromSimple \_ -> returnMempty) (_foo e) })+--      do r <- foo' 7+--         print r+-- :}+-- Sum {getSum = 7}+-- Sum {getSum = 0}+runFromEnv ::+  forall as e_ m r curried.+  Multicurryable as e_ m r curried =>+  -- | action that gets hold of the environment+  m (e_ (DepT e_ m)) ->+  -- | gets a function from the environment with effects in 'DepT'+  (e_ (DepT e_ m) -> curried) ->+  -- | a new function with effects in the base monad+  DownToBaseMonad as e_ m r curried+runFromEnv = _runFromEnv++-- | Like 'runFromEnv', but the function to run is extracted from a dependency+-- @dep@ which is found using 'Has'. The selector should be concrete enough to+-- identify @dep@ in the environment.+runFromDep ::+  forall dep as e_ m r curried.+  (Multicurryable as e_ m r curried, Has dep (DepT e_ m) (e_ (DepT e_ m))) =>+  -- | action that gets hold of the environment+  m (e_ (DepT e_ m)) ->+  -- | selector that gets a function from a dependency found using 'Has'+  (dep (DepT e_ m) -> curried) ->+  -- | a new function with effects in the base monad+  DownToBaseMonad as e_ m r curried+runFromDep envAction member = _runFromEnv envAction (member . dep)++-- $restrict+--+--    'Advice' values can be composed using the 'Monoid' instance, but only if+--    they have the same type parameters. It's unfortunate that—unlike with+--    normal function constraints—the @ca@ constraints of an 'Advice' aren't+--    automatically "collected" during composition.+--+--    Instead, we need to harmonize the @ca@ constraints of each 'Advice' by+--    turning them into the combination of all constraints. 'restrictArgs'+--    helps with that.+--+--    'restrictArgs' takes as parameter value-level "\evidence\" that one+--    constraint implies another. But how to construct such evidence? By using+--    the 'Dict' GADT, more precisely the deceptively simple-looking term+--    @\\Dict -> Dict@. That function "absorbs" some constraint present in the+--    ambient context and re-packages it a a new constraint that is implied by+--    the former. We can't rely on type inference here; we need to provide+--    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) e_ m r+--  stricterPrintArgs = restrictArgs (\Dict -> Dict) (fromSimple \_ -> printArgs stdout "foo")+-- :}+--+--    or with a type application to 'restrictArgs':+--+-- >>> stricterPrintArgs = restrictArgs @(Show `And` Eq `And` Ord) (\Dict -> Dict) (fromSimple \_ -> printArgs stdout "foo")++-- | Makes the constraint on the arguments more restrictive.+restrictArgs ::+  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) ->+  -- | Advice with less restrictive constraint on the args.+  Advice less e_ m r ->+  -- | Advice with more restrictive constraint on the args.+  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+-- come pre-packaged and having a type signature.+-- We arent' so sure about having a signature for a whole composed Advice,+-- because the composition might be done+-- on the fly, while constructing a record, without a top-level binding with a+-- type signature.  This seems to favor putting "more" first.+restrictArgs evidence (Advice advice) = Advice \args ->+    let advice' :: forall as. All more as => NP I as -> DepT e_ m (DepT e_ m r -> DepT e_ m r, NP I as)+        advice' args' =+            case Data.SOP.Dict.mapAll @more @less evidence of+               f -> case f (Dict @(All more) @as) of+                        Dict -> advice args'+     in advice' args++--+type Gullible ::+  [Type] ->+  Type ->+  ((Type -> Type) -> Type) ->+  (Type -> Type) ->+  Type ->+  Type ->+  Constraint+class Multicurryable as e_ m r curried => Gullible as e e_ m r curried where+  type NewtypedEnv as e e_ m r curried :: Type+  _deceive :: (e_ (DepT e_ m) -> e) -> NewtypedEnv as e e_ m r curried -> curried++instance Monad m => Gullible '[] e e_ m r (DepT e_ m r) where+  type NewtypedEnv '[] e e_ m r (DepT e_ m r) = ReaderT e m r+  _deceive f action = DepT (withReaderT f action)++instance (Functor m, Gullible as e e_ m r curried) => Gullible (a ': as) e e_ m r (a -> curried) where+  type NewtypedEnv (a ': as) e e_ m r (a -> curried) = a -> NewtypedEnv as e e_ m r curried+  _deceive f g a = deceive @as @e @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 e e_ m r curried.+  Gullible as e e_ m r curried =>+  -- | The newtype constructor that masks the \"true\" environment.+  (e_ (DepT e_ m) -> e) ->+  -- | A function to be deceived. It must be polymorphic over 'Control.Monad.Dep.MonadDep'.+  NewtypedEnv as e e_ m r curried ->+  -- | The deceived function, that has effects in 'DepT'.+  curried+deceive = _deceive++-- deceving *all* fields of a record+--+--+type GullibleRecord :: Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> ((Type -> Type) -> Type) -> Constraint+class GullibleRecord e e_ m gullible where+  _deceiveRecord :: (e_ (DepT e_ m) -> e) -> gullible (ReaderT e m) -> gullible (DepT e_ m)++-- https://gitlab.haskell.org/ghc/ghc/-/issues/13952+type GullibleProduct :: Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> (k -> Type) -> (k -> Type) -> Constraint+class GullibleProduct e e_ m gullible_ deceived_ | e e_ m deceived_ -> gullible_ where+  _deceiveProduct :: (e_ (DepT e_ m) -> e) -> gullible_ k -> deceived_ k++instance+  ( GullibleProduct e e_ m gullible_left deceived_left,+    GullibleProduct e e_ m gullible_right deceived_right+  ) =>+  GullibleProduct e e_ m (gullible_left G.:*: gullible_right) (deceived_left G.:*: deceived_right)+  where+  _deceiveProduct f (gullible_left G.:*: gullible_right) = _deceiveProduct @_ @e @e_ @m f gullible_left G.:*: _deceiveProduct @_ @e @e_ @m f gullible_right++data RecordComponent+  = Terminal+  | IWrapped+  | Recurse++type DiscriminateGullibleComponent :: Type -> RecordComponent+type family DiscriminateGullibleComponent c where+  DiscriminateGullibleComponent (a -> b) = Terminal+  DiscriminateGullibleComponent (ReaderT e m x) = Terminal+  DiscriminateGullibleComponent (Identity _) = IWrapped+  DiscriminateGullibleComponent (I _) = IWrapped+  DiscriminateGullibleComponent _ = Recurse++type GullibleComponent :: RecordComponent -> Type -> ((Type -> Type) -> Type) -> (Type -> Type) -> Type -> Type -> Constraint+class GullibleComponent component_type e e_ m gullible deceived | e e_ m deceived -> gullible where+  _deceiveComponent :: (e_ (DepT e_ m) -> e) -> gullible -> deceived++instance+  (Gullible as e e_ m r deceived, NewtypedEnv as e e_ m r deceived ~ gullible) =>+  GullibleComponent Terminal e e_ m gullible deceived+  where+  _deceiveComponent f gullible = deceive @as @e @_ @m @r f gullible++instance+  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>+  GullibleComponent IWrapped e e_ m (Identity gullible) (Identity deceived)+  where+  _deceiveComponent f (Identity gullible) = Identity (_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m f gullible)++instance+  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>+  GullibleComponent IWrapped e e_ m (I gullible) (I deceived)+  where+  _deceiveComponent f (I gullible) = I (_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m f gullible)++instance+  GullibleRecord e e_ m gullible =>+  GullibleComponent Recurse e e_ m (gullible (ReaderT e m)) (gullible (DepT e_ m))+  where+  _deceiveComponent f gullible = _deceiveRecord @e @e_ @m f gullible++instance+  GullibleComponent (DiscriminateGullibleComponent gullible) e e_ m gullible deceived =>+  GullibleProduct e e_ m (G.S1 x (G.Rec0 gullible)) (G.S1 x (G.Rec0 deceived))+  where+  _deceiveProduct f (G.M1 (G.K1 gullible)) = G.M1 (G.K1 (_deceiveComponent @(DiscriminateGullibleComponent gullible) @e @e_ @m f gullible))++instance+  ( G.Generic (gullible (ReaderT e m)),+    G.Generic (gullible (DepT e_ m)),+    G.Rep (gullible (ReaderT e m)) ~ G.D1 x (G.C1 y gullible_),+    G.Rep (gullible (DepT e_ m)) ~ G.D1 x (G.C1 y deceived_),+    GullibleProduct e e_ m gullible_ deceived_+  ) =>+  GullibleRecord e e_ m gullible+  where+  _deceiveRecord f gullible =+    let G.M1 (G.M1 gullible_) = G.from gullible+        deceived_ = _deceiveProduct @_ @e @e_ @m f gullible_+     in G.to (G.M1 (G.M1 deceived_))++-- | Makes an entire record-of-functions see a different version of the global environment record, a version that might have different @HasX@ instances.+--+-- 'deceiveRecord' must be applied before 'adviseRecord'.+deceiveRecord ::+  forall e e_ m gullible.+  GullibleRecord e e_ m gullible =>+  -- | The newtype constructor that masks the \"true\" environment.+  (e_ (DepT e_ m) -> e) ->+  -- | The record to deceive recursively. The monad parameter must be left polymorphic over @MonadDep@, so that it can unify with `ReaderT`.+  gullible (ReaderT e m) ->+  -- | The deceived record.+  gullible (DepT e_ m)+deceiveRecord = _deceiveRecord @e @e_ @m @gullible+++-- | Given a constructor that returns a record-of-functions with effects in 'DepT',+-- produce a record in which the member functions 'ask' for the environment themselves.+--+-- You must have a sufficiently polymorphic constructor—both in the monad and+-- in the environment—to invoke this function.+--+-- 'component' lets you plug simple component constructors +-- into a 'DepT'-based environment.+--+-- Compare with 'Control.Monad.Dep.Env.constructor' from "Control.Monad.Dep.Env", which +-- is intended to be used with 'Control.Monad.Dep.Env.fixEnv'-based environments.+component +    :: forall e_ m record . (Applicative m, DistributiveRecord e_ m record) => +    -- | constructor which takes the environment as a positional parameter.+    (e_ (DepT e_ m) -> record (DepT e_ m)) ->+    -- | component whose methods get the environment by 'ask'ing.+    record (DepT e_ m)+component f = _distribute @e_ @m (pure . f)++++type DistributiveRecord :: ((Type -> Type) -> Type) -> (Type -> Type) -> ((Type -> Type) -> Type) -> Constraint+class DistributiveRecord e_ m record where+    _distribute :: (e_ (DepT e_ m) -> m (record (DepT e_ m))) -> record (DepT e_ m)++type DistributiveProduct :: ((Type -> Type) -> Type) -> (Type -> Type) -> (k -> Type) -> Constraint+class DistributiveProduct e_ m product where+    _distributeProduct :: (e_ (DepT e_ m) -> m (product k)) -> product k++instance+  ( G.Generic (advised (DepT e_ m)),+    G.Rep (advised (DepT e_ m)) ~ G.D1 x (G.C1 y advised_),+    DistributiveProduct e_ m advised_,+    Functor m+  ) =>+  DistributiveRecord e_ m advised+  where+  _distribute f =+    let advised_ = _distributeProduct @_ @e_ @m (fmap (fmap (G.unM1 . G.unM1 . G.from)) f)+     in G.to (G.M1 (G.M1 advised_))++instance+  ( DistributiveProduct e_ m advised_left,+    DistributiveProduct e_ m advised_right,+    Functor m+  ) =>+  DistributiveProduct e_ m (advised_left G.:*: advised_right)+  where+  _distributeProduct f  = +      _distributeProduct @_ @e_ @m (fmap (fmap (\(l G.:*: _) -> l)) f) +      G.:*: +      _distributeProduct @_ @e_ @m (fmap (fmap (\(_ G.:*: r) -> r)) f) ++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+  ) =>+  DistributiveSubcomponent Terminal e_ m advised+  where+  _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+--+--+type AdvisedRecord :: (Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> Constraint+class AdvisedRecord ca e_ m cr advised where+  _adviseRecord :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r) -> advised (DepT e_ m) -> advised (DepT e_ m)++type AdvisedProduct :: (Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> (Type -> Constraint) -> (k -> Type) -> Constraint+class AdvisedProduct ca e_ m cr advised_ where+  _adviseProduct :: TypeRep -> [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r) -> advised_ k -> advised_ k++instance+  ( G.Generic (advised (DepT e_ m)),+    -- G.Rep (advised (DepT e_ m)) ~ G.D1 ('G.MetaData name mod p nt) (G.C1 y advised_),+    G.Rep (advised (DepT e_ m)) ~ G.D1 x (G.C1 y advised_),+    Typeable advised,+    AdvisedProduct ca e_ m cr advised_+  ) =>+  AdvisedRecord ca e_ m cr advised+  where+  _adviseRecord acc f unadvised =+    let G.M1 (G.M1 unadvised_) = G.from unadvised+        advised_ = _adviseProduct @_ @ca @e_ @m @cr (typeRep (Proxy @advised)) acc f unadvised_+     in G.to (G.M1 (G.M1 advised_))++instance+  ( AdvisedProduct ca e_ m cr advised_left,+    AdvisedProduct ca e_ m cr advised_right+  ) =>+  AdvisedProduct ca e_ m cr (advised_left G.:*: advised_right)+  where+  _adviseProduct tr acc f (unadvised_left G.:*: unadvised_right) = _adviseProduct @_ @ca @e_ @m @cr tr acc f unadvised_left G.:*: _adviseProduct @_ @ca @e_ @m @cr tr acc f unadvised_right++type DiscriminateAdvisedComponent :: Type -> RecordComponent+type family DiscriminateAdvisedComponent c where+  DiscriminateAdvisedComponent (a -> b) = Terminal+  DiscriminateAdvisedComponent (DepT e_ m x) = Terminal+  DiscriminateAdvisedComponent (Identity _) = IWrapped+  DiscriminateAdvisedComponent (I _) = IWrapped+  DiscriminateAdvisedComponent _ = Recurse++type AdvisedComponent :: RecordComponent -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> (Type -> Type) -> (Type -> Constraint) -> Type -> Constraint+class AdvisedComponent component_type ca e_ m cr advised where+  _adviseComponent :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r) -> advised -> advised++instance+  ( AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised,+    KnownSymbol fieldName+  ) =>+  AdvisedProduct ca e_ m cr (G.S1 ( 'G.MetaSel ( 'Just fieldName) su ss ds) (G.Rec0 advised))+  where+  _adviseProduct tr acc f (G.M1 (G.K1 advised)) =+    let acc' = (tr, symbolVal (Proxy @fieldName)) : acc+     in G.M1 (G.K1 (_adviseComponent @(DiscriminateAdvisedComponent advised) @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+  _adviseComponent acc f advised = advise @ca @e_ @m (f (N.fromList acc)) advised++instance+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised =>+  AdvisedComponent IWrapped ca e_ m cr (Identity advised)+  where+  _adviseComponent acc f (Identity advised) = Identity (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e_ @m @cr acc f advised)++instance+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e_ m cr advised =>+  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.+--+-- The function that builds the advice receives a list of tuples @(TypeRep, String)@+-- which represent the record types and fields names we have+-- traversed until arriving at the advised function. This info can be useful for+-- logging advices. It's a list instead of a single tuple because+-- 'adviseRecord' works recursively. The elements come innermost-first.+--+-- __/TYPE APPLICATION REQUIRED!/__ The @ca@ constraint on function arguments+-- and the @cr@ constraint on the result type must be supplied by means of a+-- type application. Supply 'Top' if no constraint is required.+adviseRecord ::+  forall ca cr e_ m advised.+  AdvisedRecord ca e_ m cr advised =>+  -- | The advice to apply.+  (forall r . cr r => NonEmpty (TypeRep, String) -> Advice ca e_ m r) ->+  -- | The record to advise recursively.+  advised (DepT e_ m) ->+  -- | The advised record.+  advised (DepT e_ m)+adviseRecord = _adviseRecord @ca @e_ @m @cr []++-- $records+--+-- 'adviseRecord' and 'deceiveRecord' are versions of 'advise' and 'deceive' that, instead of working on bare+-- functions, transform entire records-of-functions in one go. They also work+-- with newtypes containing a single function. The records must derive 'GHC.Generics.Generic'.+--+-- Useful with the \"wrapped\" style of components facilitated by @Control.Monad.Dep.Has@.+--+-- >>> :{+--   type Logger :: (Type -> Type) -> Type+--   newtype Logger d = Logger {log :: String -> d ()} deriving Generic+--   type Repository :: (Type -> Type) -> Type+--   data Repository d = Repository+--     { select :: String -> d [Int],+--       insert :: [Int] -> d ()+--     } deriving Generic+--   type Controller :: (Type -> Type) -> Type+--   newtype Controller d = Controller {serve :: Int -> d String} deriving Generic+--   type Env :: (Type -> Type) -> Type+--   data Env m = Env+--     { logger :: Logger m,+--       repository :: Repository m,+--       controller :: Controller m+--     }+--   newtype Wraps x = Wraps x+--   env :: Env (DepT Env (Writer ()))+--   env =+--     let logger = Logger \_ -> pure ()+--         repository =+--           adviseRecord @Top @Top mempty $+--           deceiveRecord Wraps $+--           Repository {select = \_ -> pure [], insert = \_ -> pure ()}+--         controller =+--           adviseRecord @Top @Top mempty $+--           deceiveRecord Wraps $+--           Controller \_ -> pure "view"+--      in Env {logger, repository, controller}+-- :}++-- $sop+-- Some useful definitions re-exported the from \"sop-core\" package.+--+-- 'NP' is an n-ary product used to represent the arguments of advised functions.+--+-- 'I' is an identity functor. The arguments processed by an 'Advice' come wrapped in it.+--+-- 'cfoldMap_NP' is useful to construct homogeneous lists out of the 'NP' product, for example:+--+-- >>> cfoldMap_NP (Proxy @Show) (\(I a) -> [show a]) (I False :* I (1::Int) :* Nil)+-- ["False","1"]++-- $constraints+--+-- Some useful definitions re-exported the from \"constraints\" package.+--+-- 'Dict' and '(:-)' are GADTs used to capture and transform constraints. Used in the 'restrictArgs' function.++-- $constrainthelpers+--+-- To help with the constraint @ca@ that parameterizes 'Advice', this library re-exports the following helpers from \"sop-core\":+--+-- * 'Top' is the \"always satisfied\" constraint, useful when whe don't want to require anything specific in @ca@.+--+-- * 'And' combines two constraints so that an 'Advice' can request them both, for example @Show \`And\` Eq@.+--+-- Also, the 'All' constraint says that some constraint is satisfied by all the+-- components of an 'NP' product. It's in scope when processing the function+-- arguments inside an 'Advice'.++-- $invocation+-- These functions are helpers for running 'DepT' computations, beyond what 'runDepT' provides.+--+-- They aren't directly related to 'Advice's, but they require some of the same machinery, and that's why they are here.++-- | An advice that is polymorphic on the environment (allowing it to unify+-- with 'Control.Monad.Dep.NilEnv') can be converted to a "simple" 'Control.Monad.Dep.SimpleAdvice.Advice' that doesn't require 'Control.Monad.Dep.DepT' at all. +toSimple :: Monad m => Advice ca NilEnv m r -> SA.Advice ca m r+toSimple (Advice f) = SA.Advice \args -> lift do+    (withExecution, args') <- f args `runDepT` NilEnv+    let withExecution' = lift . flip runDepT NilEnv . withExecution . lift . SA.runAspectT+    pure (withExecution', args')++-- | Convert a simple 'Control.Monad.Dep.SimpleAdvice.Advice' whose monad unifies with `DepT e_ m` into an 'Advice'.+fromSimple :: forall ca e_ m r. Monad m => (e_ (DepT e_ m) -> SA.Advice ca (DepT e_ m) r) -> Advice ca e_ m r+fromSimple makeAdvice = Advice \args -> do+    env <- ask+    case makeAdvice env of+        SA.Advice f -> do+            let SA.AspectT argsAction = f args+            (tweakExecution, args') <- argsAction+            pure (coerce tweakExecution, args')++-- | Like 'fromSimple', but for 'Control.Monad.Dep.SimpleAdvice.Advice's that don't use the environment.+fromSimple_ :: forall ca e_ m r. Monad m => SA.Advice ca (DepT e_ m) r -> Advice ca e_ m r+fromSimple_ advice = fromSimple \_ -> advice+

@@ -1,195 +1,195 @@-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-
--- |
--- This module contains basic examples advices.
---
--- __/BEWARE!/__ These are provided for illustrative purposes only, they
--- strive for simplicity and not robustness or efficiency.
-module Dep.Advice.Basic
-  ( -- * Basic advices
-    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
-import Data.SOP (hctraverse_)
-import Data.SOP.NP
-import Data.Type.Equality
-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
---
--- >>> :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 Dep.Advice
--- >>> import Dep.Advice.Basic
--- >>> import Control.Monad
--- >>> import Control.Monad.Dep
--- >>> import Data.Kind
--- >>> import Data.SOP
--- >>> import Data.SOP.NP
--- >>> import Data.Monoid
--- >>> import System.IO
--- >>> import Data.IORef
-
-
--- | 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 into dependencies. 
---
--- 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
---    logger :: em -> String -> m ()
---  type Env :: (Type -> Type) -> Type
---  data Env m = Env
---    { _logger1 :: String -> m (),
---      _logger2 :: String -> m (),
---      _controllerA :: Int -> m (),
---      _controllerB :: Int -> m ()
---    }
---  instance HasLogger (Env m) m where
---    logger = _logger1
---  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" 
---    }
--- :}
---
---  >>> runFromEnv (pure envIO) _controllerA 0
---  logger1 ran
---
---  >>> runFromEnv (pure envIO) _controllerB 0
---  logger2 ran
---
-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
+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}+++-- |+-- This module contains basic examples advices.+--+-- __/BEWARE!/__ These are provided for illustrative purposes only, they+-- strive for simplicity and not robustness or efficiency.+module Dep.Advice.Basic+  ( -- * Basic advices+    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+import Data.SOP (hctraverse_)+import Data.SOP.NP+import Data.Type.Equality+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+--+-- >>> :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 Dep.Advice+-- >>> import Dep.Advice.Basic+-- >>> import Control.Monad+-- >>> import Control.Monad.Dep+-- >>> import Data.Kind+-- >>> import Data.SOP+-- >>> import Data.SOP.NP+-- >>> import Data.Monoid+-- >>> import System.IO+-- >>> import Data.IORef+++-- | 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 into dependencies. +--+-- 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+--    logger :: em -> String -> m ()+--  type Env :: (Type -> Type) -> Type+--  data Env m = Env+--    { _logger1 :: String -> m (),+--      _logger2 :: String -> m (),+--      _controllerA :: Int -> m (),+--      _controllerB :: Int -> m ()+--    }+--  instance HasLogger (Env m) m where+--    logger = _logger1+--  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" +--    }+-- :}+--+--  >>> runFromEnv (pure envIO) _controllerA 0+--  logger1 ran+--+--  >>> runFromEnv (pure envIO) _controllerB 0+--  logger2 ran+--+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)

@@ -0,0 +1,533 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE InstanceSigs #-}++-- |+--    This module provides the 'Advice' datatype, along for functions for creating,+--    manipulating, composing and applying values of that type.+--+--    'Advice's are type-preserving transformations on 'IO'-effectful functions of+--    any number of arguments.+--+-- >>> :{+--    foo0 :: IO (Sum Int)+--    foo0 = pure (Sum 5)+--    foo1 :: Bool -> IO (Sum Int)+--    foo1 _ = foo0+--    foo2 :: Char -> Bool -> IO (Sum Int)+--    foo2 _ = foo1+-- :}+--+-- They work for @IO@-actions of zero arguments:+--+-- >>> advise (printArgs stdout "foo0") foo0 +-- foo0:+-- <BLANKLINE>+-- Sum {getSum = 5}+--+-- And for functions of one or more arguments, provided they end on a @IO@-action:+--+-- >>> advise (printArgs stdout "foo1") foo1 False+-- foo1: False+-- <BLANKLINE>+-- Sum {getSum = 5}+--+-- >>> advise (printArgs stdout "foo2") foo2 'd' False+-- foo2: 'd' False+-- <BLANKLINE>+-- Sum {getSum = 5}+--+-- 'Advice's can also tweak the result value of functions:+--+-- >>> advise (returnMempty @Top) foo2 'd' False+-- Sum {getSum = 0}+--+-- And they can be combined using @Advice@'s 'Monoid' instance before being+-- applied:+--+-- >>> advise (printArgs stdout "foo2" <> returnMempty) foo2 'd' False+-- foo2: 'd' False+-- <BLANKLINE>+-- Sum {getSum = 0}+--+-- Although sometimes composition might require harmonizing the constraints+-- each 'Advice' places on the arguments, if they differ.+module Dep.IOAdvice+  ( -- * The Advice type+    Advice,++    -- * Creating Advice values+    makeAdvice,+    makeArgsAdvice,+    makeExecutionAdvice,++    -- * Applying Advices+    advise,++    -- * Harmonizing Advice argument constraints+    -- $restrict+    restrictArgs,++    -- * Advising and deceiving entire records+    -- $records+    adviseRecord,+    -- * "sop-core" re-exports+    -- $sop+    Top,+    And,+    All,+    NP (..),+    I (..),+    cfoldMap_NP,+    Dict (..)+  )+where++import Dep.Has+import Dep.Env+import Data.Functor.Identity+import Data.Kind+import Data.List.NonEmpty qualified as N+import Data.List.NonEmpty (NonEmpty)+import Data.SOP+import Data.SOP.Dict+import Data.SOP.NP+import Data.Typeable+import GHC.Generics qualified as G+import GHC.TypeLits+import Data.Coerce+import Data.Bifunctor (first)++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XStandaloneKindSignatures+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XFunctionalDependencies+-- >>> :set -XRankNTypes+-- >>> :set -XTypeOperators+-- >>> :set -XConstraintKinds+-- >>> :set -XNamedFieldPuns+-- >>> :set -XFlexibleContexts+-- >>> :set -XDerivingStrategies+-- >>> :set -XGeneralizedNewtypeDeriving+-- >>> :set -XDataKinds+-- >>> :set -XScopedTypeVariables+-- >>> :set -XDeriveGeneric+-- >>> :set -XImportQualifiedPost+-- >>> import Dep.IOAdvice+-- >>> import Dep.IOAdvice.Basic (printArgs,returnMempty)+-- >>> import Control.Monad+-- >>> import Control.Monad.Reader+-- >>> import Control.Monad.Writer+-- >>> import Data.Kind+-- >>> import Data.SOP+-- >>> import Data.SOP.NP+-- >>> import Data.Monoid+-- >>> import System.IO+-- >>> import Data.IORef+-- >>> import Data.Function ((&))+-- >>> import GHC.Generics (Generic)+-- >>> import GHC.Generics qualified+++-- | A generic transformation of 'IO'-effectful functions of return type @r@,+-- provided the functions satisfy certain constraint @ca@ on all of their+-- arguments.+--+-- 'Advice's that don't care about the @ca@ constraint (because they don't+-- touch function arguments) can leave it polymorphic, and this facilitates+-- 'Advice' composition, but then the constraint must be given the catch-all+-- `Top` value (using a type application) at the moment of calling 'advise'.+--+-- See "Dep.IOAdvice.Basic" for examples.+type Advice ::+  (Type -> Constraint) ->+  Type ->+  Type+data Advice (ca :: Type -> Constraint) r where+  Advice ::+    forall ca r.+    ( forall as.+      All ca as =>+      NP I as ->+      IO (IO r -> IO r, NP I as)+    ) ->+    Advice ca r++-- |+--    'Advice's compose \"sequentially\" when tweaking the arguments, and+--    \"concentrically\" when tweaking the final 'IO' 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 Semigroup (Advice ca r) where+  Advice outer <> Advice inner = Advice \args -> do+    (tweakOuter, argsOuter) <- outer args+    (tweakInner, argsInner) <- inner argsOuter+    pure (tweakOuter . tweakInner, argsInner)++instance Monoid (Advice ca r) where+  mappend = (<>)+  mempty = Advice \args -> pure (id, args)++-- |+--    The most general way of constructing 'Advice's.+--+--    An 'Advice' is a function that transforms other functions in an +--    arity-polymorphic way. It receives the arguments of the advised+--    function packed into an n-ary product 'NP', performs some +--    effects based on them, and returns a potentially modified version of the +--    arguments, along with a function for tweaking the execution of the+--    advised function.+--+-- >>> :{+--  doesNothing :: forall ca r. Advice ca r+--  doesNothing = makeAdvice (\args -> pure (id,  args)) +-- :}+--+--+makeAdvice ::+  forall ca r.+  -- | The function that tweaks the arguments and the execution.+  ( forall as.+    All ca as =>+    NP I as ->+    IO (IO r -> IO r, NP I as)+  ) ->+  Advice ca r+makeAdvice = Advice++-- |+--    Create an advice which only tweaks and/or analyzes the function arguments.+--+-- >>> :{+--  doesNothing :: forall ca r. Advice ca r+--  doesNothing = makeArgsAdvice pure+-- :}+makeArgsAdvice ::+  forall ca r.+  -- | The function that tweaks the arguments.+  ( forall as.+    All ca as =>+    NP I as ->+    IO (NP I as)+  ) ->+  Advice ca r+makeArgsAdvice tweakArgs =+  makeAdvice $ \args -> do+    args' <- tweakArgs args+    pure (id, args')++-- |+--    Create an advice which only tweaks the execution of the final monadic action.+--+-- >>> :{+--  doesNothing :: forall ca r. Advice ca r+--  doesNothing = makeExecutionAdvice id+-- :}+makeExecutionAdvice ::+  forall ca r.+  -- | The function that tweaks the execution.+  ( IO r ->+    IO r+  ) ->+  Advice ca r+makeExecutionAdvice tweakExecution = makeAdvice \args -> pure (tweakExecution, args)++data Pair a b = Pair !a !b++-- | Apply an 'Advice' to some compatible function. The function must have its+-- effects in 'IO', and all of its arguments must satisfy the @ca@ constraint.+--+-- >>> :{+--  foo :: Int -> IO String+--  foo _ = pure "foo"+--  advisedFoo = advise (printArgs stdout "Foo args: ") foo+-- :}+--+-- __/TYPE APPLICATION REQUIRED!/__ If the @ca@ constraint of the 'Advice' remains polymorphic,+-- it must be supplied by means of a type application:+--+-- >>> :{+--  bar :: Int -> IO String+--  bar _ = pure "bar"+--  advisedBar1 = advise (returnMempty @Top) bar+--  advisedBar2 = advise @Top returnMempty bar+-- :}+advise ::+  forall ca r as advisee.+  (Multicurryable as r advisee, All ca as) =>+  -- | The advice to apply.+  Advice ca r ->+  -- | A function to be adviced.+  advisee ->+  advisee+advise (Advice f) advisee =+  let uncurried = multiuncurry @as @r advisee+      uncurried' args = do+        (tweakExecution, args') <- f args+        tweakExecution (uncurried args')+   in multicurry @as @r uncurried'++type Multicurryable ::+  [Type] ->+  Type ->+  Type ->+  Constraint+class Multicurryable as r curried | curried -> as r where+  multiuncurry :: curried -> NP I as -> IO r+  multicurry :: (NP I as -> IO r) -> curried++instance Multicurryable '[] r (IO r) where+  multiuncurry :: IO r -> NP I '[] -> IO r+  multiuncurry action Nil = action+  multicurry f = f Nil++instance (Multicurryable as r curried) => Multicurryable (a ': as) r (a -> curried) where+  multiuncurry f (I a :* as) = multiuncurry @as @r @curried (f a) as+  multicurry f a = multicurry @as @r @curried (f . (:*) (I a))++-- $restrict+--+--    'Advice' values can be composed using the 'Monoid' instance, but only if+--    they have the same type parameters. It's unfortunate that—unlike with+--    normal function constraints—the @ca@ constraints of an 'Advice' aren't+--    automatically "collected" during composition.+--+--    Instead, we need to harmonize the @ca@ constraints of each 'Advice' by+--    turning them into the combination of all constraints. 'restrictArgs'+--    helps with that.+--+--    'restrictArgs' takes as parameter value-level "\evidence\" that one+--    constraint implies another. But how to construct such evidence? By using+--    the 'Dict' GADT, more precisely the deceptively simple-looking term+--    @\\Dict -> Dict@. That function "absorbs" some constraint present in the+--    ambient context and re-packages it a a new constraint that is implied by+--    the former. We can't rely on type inference here; we need to provide+--    enough type information to the GADT, be it as an explicit signature:+--+-- >>> :{+--  stricterPrintArgs :: forall r. Advice (Show `And` Eq `And` Ord) 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 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) ->+  -- | Advice with less restrictive constraint on the args.+  Advice less r ->+  -- | Advice with more restrictive constraint on the args.+  Advice more 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+-- come pre-packaged and having a type signature.+-- We arent' so sure about having a signature for a whole composed Advice,+-- because the composition might be done+-- on the fly, while constructing a record, without a top-level binding with a+-- type signature.  This seems to favor putting "more" first.+restrictArgs evidence (Advice advice) = Advice \args ->+    let advice' :: forall as. All more as => NP I as -> IO (IO r -> IO r, NP I as)+        advice' args' =+            case Data.SOP.Dict.mapAll @more @less evidence of+               f -> case f (Dict @(All more) @as) of+                        Dict -> advice args'+     in advice' args+++data RecordComponent+  = Terminal+  | IWrapped+  | Recurse++-- advising *all* fields of a record+--+--+type AdvisedRecord :: (Type -> Constraint) -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> Constraint+class AdvisedRecord ca cr advised where+  _adviseRecord :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca r) -> advised IO -> advised IO++type AdvisedProduct :: (Type -> Constraint) -> (Type -> Constraint) -> (k -> Type) -> Constraint+class AdvisedProduct ca cr advised_ where+  _adviseProduct :: TypeRep -> [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca r) -> advised_ k -> advised_ k++instance+  ( G.Generic (advised IO),+    G.Rep (advised IO) ~ G.D1 x (G.C1 y advised_),+    Typeable advised,+    AdvisedProduct ca cr advised_+  ) =>+  AdvisedRecord ca cr advised+  where+  _adviseRecord acc f unadvised =+    let G.M1 (G.M1 unadvised_) = G.from unadvised+        advised_ = _adviseProduct @_ @ca @cr (typeRep (Proxy @advised)) acc f unadvised_+     in G.to (G.M1 (G.M1 advised_))++instance+  ( AdvisedProduct ca cr advised_left,+    AdvisedProduct ca cr advised_right+  ) =>+  AdvisedProduct ca cr (advised_left G.:*: advised_right)+  where+  _adviseProduct tr acc f (unadvised_left G.:*: unadvised_right) = _adviseProduct @_ @ca @cr tr acc f unadvised_left G.:*: _adviseProduct @_ @ca @cr tr acc f unadvised_right++type DiscriminateAdvisedComponent :: Type -> RecordComponent+type family DiscriminateAdvisedComponent c where+  DiscriminateAdvisedComponent (_ -> _) = 'Terminal+  DiscriminateAdvisedComponent (IO _) = 'Terminal+  DiscriminateAdvisedComponent (Identity _) = 'IWrapped+  DiscriminateAdvisedComponent (I _) = 'IWrapped+  DiscriminateAdvisedComponent _ = 'Recurse++type AdvisedComponent :: RecordComponent -> (Type -> Constraint) -> (Type -> Constraint) -> Type -> Constraint+class AdvisedComponent component_type ca cr advised where+  _adviseComponent :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca r) -> advised -> advised++instance+  ( AdvisedComponent (DiscriminateAdvisedComponent advised) ca cr advised,+    KnownSymbol fieldName+  ) =>+  AdvisedProduct ca cr (G.S1 ( 'G.MetaSel ( 'Just fieldName) su ss ds) (G.Rec0 advised))+  where+  _adviseProduct tr acc f (G.M1 (G.K1 advised)) =+    let acc' = (tr, symbolVal (Proxy @fieldName)) : acc+     in G.M1 (G.K1 (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @cr acc' f advised))++instance+  (Multicurryable as r advised, All ca as, cr r) =>+  AdvisedComponent 'Terminal ca cr advised+  where+  _adviseComponent acc f advised = advise @ca (f (N.fromList acc)) advised++instance+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca cr advised =>+  AdvisedComponent 'IWrapped ca cr (Identity advised)+  where+  _adviseComponent acc f (Identity advised) = Identity (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @cr acc f advised)++instance+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca cr advised =>+  AdvisedComponent 'IWrapped ca cr (I advised)+  where+  _adviseComponent acc f (I advised) = I (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @cr acc f advised)++instance+  AdvisedRecord ca cr advisable =>+  AdvisedComponent 'Recurse ca cr (advisable IO)+  where+  _adviseComponent acc f advised = _adviseRecord @ca @cr acc f advised+++-- | Gives 'Advice' to all the functions in a record-of-functions.+--+-- The function that builds the advice receives a list of tuples @(TypeRep, String)@+-- which represent the record types and fields names we have+-- traversed until arriving at the advised function. This info can be useful for+-- logging advices. It's a list instead of a single tuple because+-- 'adviseRecord' works recursively. The elements come innermost-first.+--+-- __/TYPE APPLICATION REQUIRED!/__ The @ca@ constraint on function arguments+-- and the @cr@ constraint on the result type must be supplied by means of a+-- type application. Supply 'Top' if no constraint is required.+adviseRecord ::+  forall ca cr advised.+  AdvisedRecord ca cr advised =>+  -- | The advice to apply.+  (forall r . cr r => NonEmpty (TypeRep, String) -> Advice ca r) ->+  -- | The record to advise recursively.+  advised IO ->+  -- | The advised record.+  advised IO+adviseRecord = _adviseRecord @ca @cr []++-- $records+--+-- 'adviseRecord' is a version of 'advise' that, instead of working on bare+-- functions, transforms entire records-of-functions in one go. It also works+-- with newtypes containing a single function. The records must derive 'GHC.Generics.Generic'.+--+-- Useful with the \"wrapped\" style of components facilitated by @Control.Monad.Dep.Has@.+--+-- >>> :{+--   type Logger :: (Type -> Type) -> Type+--   newtype Logger d = Logger {log :: String -> d ()} deriving Generic+--   type Repository :: (Type -> Type) -> Type+--   data Repository d = Repository+--     { select :: String -> d [Int],+--       insert :: [Int] -> d ()+--     } deriving Generic+--   type Controller :: (Type -> Type) -> Type+--   newtype Controller d = Controller {serve :: Int -> d String} deriving Generic+--   type Env :: (Type -> Type) -> Type+--   data Env m = Env+--     { logger :: Logger m,+--       repository :: Repository m,+--       controller :: Controller m+--     }+--   env :: Env IO+--   env =+--     let logger = Logger \_ -> pure ()+--         repository =+--           Repository {select = \_ -> pure [], insert = \_ -> pure ()} &+--           adviseRecord @Top @Top mempty +--         controller =+--           Controller { serve = \_ -> pure "view" } &+--           adviseRecord @Top @Top mempty +--      in Env {logger, repository, controller}+-- :}++-- $sop+-- Some useful definitions re-exported the from \"sop-core\" package.+--+-- 'NP' is an n-ary product used to represent the arguments of advised functions.+--+-- 'I' is an identity functor. The arguments processed by an 'Advice' come wrapped in it.+--+-- 'cfoldMap_NP' is useful to construct homogeneous lists out of the 'NP' product, for example:+--+-- >>> cfoldMap_NP (Proxy @Show) (\(I a) -> [show a]) (I False :* I (1::Int) :* Nil)+-- ["False","1"]++-- $constraints+--+-- Some useful definitions re-exported the from \"constraints\" package.+--+-- 'Dict' and '(:-)' are GADTs used to capture and transform constraints. Used in the 'restrictArgs' function.++-- $constrainthelpers+--+-- To help with the constraint @ca@ that parameterizes 'Advice', this library re-exports the following helpers from \"sop-core\":+--+-- * 'Top' is the \"always satisfied\" constraint, useful when whe don't want to require anything specific in @ca@.+--+-- * 'And' combines two constraints so that an 'Advice' can request them both, for example @Show \`And\` Eq@.+--+-- Also, the 'All' constraint says that some constraint is satisfied by all the+-- components of an 'NP' product. It's in scope when processing the function+-- arguments inside an 'Advice'.

@@ -0,0 +1,89 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- This module contains basic examples advices.+--+-- __/BEWARE!/__ These are provided for illustrative purposes only, they+-- strive for simplicity and not robustness or efficiency.+module Dep.IOAdvice.Basic +  ( -- * Basic advices+    returnMempty,+    printArgs,+  )+where++import Dep.IOAdvice+import Control.Monad.Dep+import Data.Proxy+import Data.SOP+import Data.SOP (hctraverse_)+import Data.SOP.NP+import Data.Type.Equality+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 Data.IORef++-- $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 Dep.IOAdvice+-- >>> import Dep.IOAdvice.Basic+-- >>> import Control.Monad+-- >>> 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 r. Monoid r => Advice ca r+returnMempty =+  makeExecutionAdvice+    ( \action -> do+        _ <- action+        pure (mempty :: r)+    )++-- | Given a 'Handle' and a prefix string, makes functions print their+-- arguments to the 'Handle'.+--+printArgs :: forall r . Handle -> String -> Advice Show r+printArgs h prefix =+  makeArgsAdvice+    ( \args -> do+        hPutStr h $ prefix ++ ":"+        hctraverse_ (Proxy @Show) (\(I a) -> hPutStr h (" " ++ show a)) args+        hPutStrLn h "\n"+        hFlush h+        pure args+    )

@@ -0,0 +1,540 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE BlockArguments #-}++-- |+--    This module provides the 'Advice' datatype, along for functions for creating,+--    manipulating, composing and applying values of that type.+--+--    'Advice's are type-preserving transformations on 'ReaderT'-effectful functions of+--    any number of arguments.+--+-- >>> :{+--    foo0 :: ReaderT () IO (Sum Int)+--    foo0 = pure (Sum 5)+--    foo1 :: Bool -> ReaderT () IO (Sum Int)+--    foo1 _ = foo0+--    foo2 :: Char -> Bool -> ReaderT () IO (Sum Int)+--    foo2 _ = foo1+-- :}+--+-- They work for @ReaderT@-actions of zero arguments:+--+-- >>> advise (printArgs stdout "foo0") foo0 `runReaderT` ()+-- foo0:+-- <BLANKLINE>+-- Sum {getSum = 5}+--+-- And for functions of one or more arguments, provided they end on a @ReaderT@-action:+--+-- >>> advise (printArgs stdout "foo1") foo1 False `runReaderT` ()+-- foo1: False+-- <BLANKLINE>+-- Sum {getSum = 5}+--+-- >>> advise (printArgs stdout "foo2") foo2 'd' False `runReaderT` ()+-- foo2: 'd' False+-- <BLANKLINE>+-- Sum {getSum = 5}+--+-- 'Advice's can also tweak the result value of functions:+--+-- >>> advise (returnMempty @Top) foo2 'd' False `runReaderT` ()+-- Sum {getSum = 0}+--+-- And they can be combined using @Advice@'s 'Monoid' instance before being+-- applied:+--+-- >>> advise (printArgs stdout "foo2" <> returnMempty) foo2 'd' False `runReaderT` ()+-- foo2: 'd' False+-- <BLANKLINE>+-- Sum {getSum = 0}+--+-- Although sometimes composition might require harmonizing the constraints+-- each 'Advice' places on the arguments, if they differ.+module Dep.ReaderAdvice+  ( -- * The Advice type+    Advice,++    -- * Creating Advice values+    makeAdvice,+    makeArgsAdvice,+    makeExecutionAdvice,++    -- * Applying Advices+    advise,++    -- * Harmonizing Advice argument constraints+    -- $restrict+    restrictArgs,++    -- * Advising and deceiving entire records+    -- $records+    adviseRecord,++    -- * "sop-core" re-exports+    -- $sop+    Top,+    And,+    All,+    NP (..),+    I (..),+    cfoldMap_NP,+    Dict (..)+  )+where++import Dep.Has+import Dep.Env+import Control.Monad.Trans.Reader (ReaderT (..), withReaderT)+import Data.Functor.Identity+import Data.Kind+import Data.List.NonEmpty qualified as N+import Data.List.NonEmpty (NonEmpty)+import Data.SOP+import Data.SOP.Dict+import Data.SOP.NP+import Data.Typeable+import GHC.Generics qualified as G+import GHC.TypeLits+import Data.Coerce+import Data.Bifunctor (first)++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XStandaloneKindSignatures+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XFunctionalDependencies+-- >>> :set -XRankNTypes+-- >>> :set -XTypeOperators+-- >>> :set -XConstraintKinds+-- >>> :set -XNamedFieldPuns+-- >>> :set -XFlexibleContexts+-- >>> :set -XDerivingStrategies+-- >>> :set -XGeneralizedNewtypeDeriving+-- >>> :set -XDataKinds+-- >>> :set -XScopedTypeVariables+-- >>> :set -XDeriveGeneric+-- >>> :set -XImportQualifiedPost+-- >>> import Dep.ReaderAdvice+-- >>> import Dep.ReaderAdvice.Basic (printArgs,returnMempty)+-- >>> import Control.Monad+-- >>> import Control.Monad.Reader+-- >>> import Control.Monad.Writer+-- >>> import Data.Kind+-- >>> import Data.SOP+-- >>> import Data.SOP.NP+-- >>> import Data.Monoid+-- >>> import System.IO+-- >>> import Data.IORef+-- >>> import Data.Function ((&))+-- >>> import GHC.Generics (Generic)+-- >>> import GHC.Generics qualified+++-- | A generic transformation of 'ReaderT'-effectful functions with environment+-- @e@, base monad @m@ and return type @r@,+-- provided the functions satisfy certain constraint @ca@+-- on all of their arguments.+--+-- 'Advice's that don't care about the @ca@ constraint (because they don't+-- touch function arguments) can leave it polymorphic, and this facilitates+-- 'Advice' composition, but then the constraint must be given the catch-all+-- `Top` value (using a type application) at the moment of calling 'advise'.+--+-- See "Dep.ReaderAdvice.Basic" for examples.+type Advice ::+  (Type -> Constraint) ->+  Type ->+  (Type -> Type) ->+  Type ->+  Type+data Advice (ca :: Type -> Constraint) e m r where+  Advice ::+    forall ca e m r.+    ( forall as.+      All ca as =>+      NP I as ->+      ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)+    ) ->+    Advice ca e m r++-- |+--    'Advice's compose \"sequentially\" when tweaking the arguments, and+--    \"concentrically\" when tweaking the final 'ReaderT' 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+  Advice outer <> Advice inner = Advice \args -> do+    (tweakOuter, argsOuter) <- outer args+    (tweakInner, argsInner) <- inner argsOuter+    pure (tweakOuter . tweakInner, argsInner)++instance Monad m => Monoid (Advice ca e m r) where+  mappend = (<>)+  mempty = Advice \args -> pure (id, args)++-- |+--    The most general way of constructing 'Advice's.+--+--    An 'Advice' is a function that transforms other functions in an +--    arity-polymorphic way. It receives the arguments of the advised+--    function packed into an n-ary product 'NP', performs some +--    effects based on them, and returns a potentially modified version of the +--    arguments, along with a function for tweaking the execution of the+--    advised function.+--+-- >>> :{+--  doesNothing :: forall ca e m r. Monad m => Advice ca e m r+--  doesNothing = makeAdvice (\args -> pure (id,  args)) +-- :}+--+--+makeAdvice ::+  forall ca e m r.+  -- | The function that tweaks the arguments and the execution.+  ( forall as.+    All ca as =>+    NP I as ->+    ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)+  ) ->+  Advice ca e m r+makeAdvice = Advice++-- |+--    Create an advice which only tweaks and/or analyzes the function arguments.+--+-- >>> :{+--  doesNothing :: forall ca e m r. Monad m => Advice ca e m r+--  doesNothing = makeArgsAdvice pure+-- :}+makeArgsAdvice ::+  forall ca e m r.+  Monad m =>+  -- | The function that tweaks the arguments.+  ( forall as.+    All ca as =>+    NP I as ->+    ReaderT e m (NP I as)+  ) ->+  Advice ca e m r+makeArgsAdvice tweakArgs =+  makeAdvice $ \args -> do+    args' <- tweakArgs args+    pure (id, args')++-- |+--    Create an advice which only tweaks the execution of the final monadic action.+--+-- >>> :{+--  doesNothing :: forall ca e m r. Monad m => Advice ca e m r+--  doesNothing = makeExecutionAdvice id+-- :}+makeExecutionAdvice ::+  forall ca e m r.+  Applicative m =>+  -- | The function that tweaks the execution.+  ( ReaderT e m r ->+    ReaderT e m r+  ) ->+  Advice ca e m r+makeExecutionAdvice tweakExecution = makeAdvice \args -> pure (tweakExecution, args)++data Pair a b = Pair !a !b++-- | Apply an 'Advice' to some compatible function. The function must have its+-- effects in 'ReaderT', and all of its arguments must satisfy the @ca@ constraint.+--+-- >>> :{+--  foo :: Int -> ReaderT () IO String+--  foo _ = pure "foo"+--  advisedFoo = advise (printArgs stdout "Foo args: ") foo+-- :}+--+-- __/TYPE APPLICATION REQUIRED!/__ If the @ca@ constraint of the 'Advice' remains polymorphic,+-- it must be supplied by means of a type application:+--+-- >>> :{+--  bar :: Int -> ReaderT () IO String+--  bar _ = pure "bar"+--  advisedBar1 = advise (returnMempty @Top) bar+--  advisedBar2 = advise @Top returnMempty bar+-- :}+advise ::+  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 ->+  -- | A function to be adviced.+  advisee ->+  advisee+advise (Advice f) advisee = do+  let uncurried = multiuncurry @as @e @m @r advisee+      uncurried' args = do+        (tweakExecution, args') <- f args+        tweakExecution (uncurried args')+   in multicurry @as @e @m @r uncurried'++type Multicurryable ::+  [Type] ->+  Type ->+  (Type -> Type) ->+  Type ->+  Type ->+  Constraint+class Multicurryable as e m r curried | curried -> as e m r where+  multiuncurry :: curried -> NP I as -> ReaderT e m r+  multicurry :: (NP I as -> ReaderT e m r) -> curried++instance Monad m => Multicurryable '[] e m r (ReaderT e m r) where+  multiuncurry action Nil = action+  multicurry f = f Nil++instance (Functor m, Multicurryable as e m r curried) => Multicurryable (a ': as) e m r (a -> curried) where+  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))++-- $restrict+--+--    'Advice' values can be composed using the 'Monoid' instance, but only if+--    they have the same type parameters. It's unfortunate that—unlike with+--    normal function constraints—the @ca@ constraints of an 'Advice' aren't+--    automatically "collected" during composition.+--+--    Instead, we need to harmonize the @ca@ constraints of each 'Advice' by+--    turning them into the combination of all constraints. 'restrictArgs'+--    helps with that.+--+--    'restrictArgs' takes as parameter value-level "\evidence\" that one+--    constraint implies another. But how to construct such evidence? By using+--    the 'Dict' GADT, more precisely the deceptively simple-looking term+--    @\\Dict -> Dict@. That function "absorbs" some constraint present in the+--    ambient context and re-packages it a a new constraint that is implied by+--    the former. We can't rely on type inference here; we need to provide+--    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) 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.+  -- | 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) ->+  -- | Advice with less restrictive constraint on the args.+  Advice less e m r ->+  -- | Advice with more restrictive constraint on the args.+  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+-- come pre-packaged and having a type signature.+-- We arent' so sure about having a signature for a whole composed Advice,+-- because the composition might be done+-- on the fly, while constructing a record, without a top-level binding with a+-- type signature.  This seems to favor putting "more" first.+restrictArgs evidence (Advice advice) = Advice \args ->+    let advice' :: forall as. All more as => NP I as -> ReaderT e m (ReaderT e m r -> ReaderT e m r, NP I as)+        advice' args' =+            case Data.SOP.Dict.mapAll @more @less evidence of+               f -> case f (Dict @(All more) @as) of+                        Dict -> advice args'+     in advice' args+++data RecordComponent+  = Terminal+  | IWrapped+  | Recurse++-- advising *all* fields of a record+--+--+type AdvisedRecord :: (Type -> Constraint) -> Type -> (Type -> Type) -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> Constraint+class AdvisedRecord ca e m cr advised where+  _adviseRecord :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r) -> advised (ReaderT e m) -> advised (ReaderT e m)++type AdvisedProduct :: (Type -> Constraint) -> Type -> (Type -> Type) -> (Type -> Constraint) -> (k -> Type) -> Constraint+class AdvisedProduct ca e m cr advised_ where+  _adviseProduct :: TypeRep -> [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r) -> advised_ k -> advised_ k++instance+  ( G.Generic (advised (ReaderT e m)),+    G.Rep (advised (ReaderT e m)) ~ G.D1 x (G.C1 y advised_),+    Typeable advised,+    AdvisedProduct ca e m cr advised_+  ) =>+  AdvisedRecord ca e m cr advised+  where+  _adviseRecord acc f unadvised =+    let G.M1 (G.M1 unadvised_) = G.from unadvised+        advised_ = _adviseProduct @_ @ca @e @m @cr (typeRep (Proxy @advised)) acc f unadvised_+     in G.to (G.M1 (G.M1 advised_))++instance+  ( AdvisedProduct ca e m cr advised_left,+    AdvisedProduct ca e m cr advised_right+  ) =>+  AdvisedProduct ca e m cr (advised_left G.:*: advised_right)+  where+  _adviseProduct tr acc f (unadvised_left G.:*: unadvised_right) = _adviseProduct @_ @ca @e @m @cr tr acc f unadvised_left G.:*: _adviseProduct @_ @ca @e @m @cr tr acc f unadvised_right++type DiscriminateAdvisedComponent :: Type -> RecordComponent+type family DiscriminateAdvisedComponent c where+  DiscriminateAdvisedComponent (_ -> _) = 'Terminal+  DiscriminateAdvisedComponent (ReaderT _ _ _) = 'Terminal+  DiscriminateAdvisedComponent (Identity _) = 'IWrapped+  DiscriminateAdvisedComponent (I _) = 'IWrapped+  DiscriminateAdvisedComponent _ = 'Recurse++type AdvisedComponent :: RecordComponent -> (Type -> Constraint) -> Type -> (Type -> Type) -> (Type -> Constraint) -> Type -> Constraint+class AdvisedComponent component_type ca e m cr advised where+  _adviseComponent :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca e m r) -> advised -> advised++instance+  ( AdvisedComponent (DiscriminateAdvisedComponent advised) ca e m cr advised,+    KnownSymbol fieldName+  ) =>+  AdvisedProduct ca e m cr (G.S1 ( 'G.MetaSel ( 'Just fieldName) su ss ds) (G.Rec0 advised))+  where+  _adviseProduct tr acc f (G.M1 (G.K1 advised)) =+    let acc' = (tr, symbolVal (Proxy @fieldName)) : acc+     in G.M1 (G.K1 (_adviseComponent @(DiscriminateAdvisedComponent advised) @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+  _adviseComponent acc f advised = advise @ca @e @m (f (N.fromList acc)) advised++instance+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e m cr advised =>+  AdvisedComponent 'IWrapped ca e m cr (Identity advised)+  where+  _adviseComponent acc f (Identity advised) = Identity (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @e @m @cr acc f advised)++instance+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca e m cr advised =>+  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 (ReaderT 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.+--+-- The function that builds the advice receives a list of tuples @(TypeRep, String)@+-- which represent the record types and fields names we have+-- traversed until arriving at the advised function. This info can be useful for+-- logging advices. It's a list instead of a single tuple because+-- 'adviseRecord' works recursively. The elements come innermost-first.+--+-- __/TYPE APPLICATION REQUIRED!/__ The @ca@ constraint on function arguments+-- and the @cr@ constraint on the result type must be supplied by means of a+-- type application. Supply 'Top' if no constraint is required.+adviseRecord ::+  forall ca cr e m advised.+  AdvisedRecord ca e m cr advised =>+  -- | The advice to apply.+  (forall r . cr r => NonEmpty (TypeRep, String) -> Advice ca e m r) ->+  -- | The record to advise recursively.+  advised (ReaderT e m) ->+  -- | The advised record.+  advised (ReaderT e m)+adviseRecord = _adviseRecord @ca @e @m @cr []++-- $records+--+-- 'adviseRecord' is a version of 'advise' that, instead of working on bare+-- functions, transforms entire records-of-functions in one go. It also works+-- with newtypes containing a single function. The records must derive 'GHC.Generics.Generic'.+--+-- Useful with the \"wrapped\" style of components facilitated by @Control.Monad.Dep.Has@.+--+-- >>> :{+--   type Logger :: (Type -> Type) -> Type+--   newtype Logger d = Logger {log :: String -> d ()} deriving Generic+--   type Repository :: (Type -> Type) -> Type+--   data Repository d = Repository+--     { select :: String -> d [Int],+--       insert :: [Int] -> d ()+--     } deriving Generic+--   type Controller :: (Type -> Type) -> Type+--   newtype Controller d = Controller {serve :: Int -> d String} deriving Generic+--   type Env :: (Type -> Type) -> Type+--   data Env m = Env+--     { logger :: Logger m,+--       repository :: Repository m,+--       controller :: Controller m+--     }+--   env :: Env (ReaderT () IO)+--   env =+--     let logger = Logger \_ -> pure ()+--         repository =+--           Repository {select = \_ -> pure [], insert = \_ -> pure ()} &+--           adviseRecord @Top @Top mempty +--         controller =+--           Controller { serve = \_ -> pure "view" } &+--           adviseRecord @Top @Top mempty +--      in Env {logger, repository, controller}+-- :}++-- $sop+-- Some useful definitions re-exported the from \"sop-core\" package.+--+-- 'NP' is an n-ary product used to represent the arguments of advised functions.+--+-- 'I' is an identity functor. The arguments processed by an 'Advice' come wrapped in it.+--+-- 'cfoldMap_NP' is useful to construct homogeneous lists out of the 'NP' product, for example:+--+-- >>> cfoldMap_NP (Proxy @Show) (\(I a) -> [show a]) (I False :* I (1::Int) :* Nil)+-- ["False","1"]++-- $constraints+--+-- Some useful definitions re-exported the from \"constraints\" package.+--+-- 'Dict' and '(:-)' are GADTs used to capture and transform constraints. Used in the 'restrictArgs' function.++-- $constrainthelpers+--+-- To help with the constraint @ca@ that parameterizes 'Advice', this library re-exports the following helpers from \"sop-core\":+--+-- * 'Top' is the \"always satisfied\" constraint, useful when whe don't want to require anything specific in @ca@.+--+-- * 'And' combines two constraints so that an 'Advice' can request them both, for example @Show \`And\` Eq@.+--+-- Also, the 'All' constraint says that some constraint is satisfied by all the+-- components of an 'NP' product. It's in scope when processing the function+-- arguments inside an 'Advice'.

@@ -0,0 +1,123 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- This module contains basic examples advices.+--+-- __/BEWARE!/__ These are provided for illustrative purposes only, they+-- strive for simplicity and not robustness or efficiency.+module Dep.ReaderAdvice.Basic +  ( -- * Basic advices+    returnMempty,+    printArgs,+    -- ** Synthetic call stacks+    Simple.MethodName,+    Simple.StackFrame,+    Simple.SyntheticCallStack,+    Simple.HasSyntheticCallStack (..),+    Simple.SyntheticStackTrace,+    Simple.SyntheticStackTraceException (..),+    keepCallStack+  )+where++import Dep.ReaderAdvice+import Control.Monad.Dep+import Data.Proxy+import Data.SOP+import Data.SOP (hctraverse_)+import Data.SOP.NP+import Data.Type.Equality+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 Data.IORef+import Dep.SimpleAdvice.Basic qualified as Simple+import Dep.SimpleAdvice.Basic (HasSyntheticCallStack)++-- $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 Dep.ReaderAdvice+-- >>> import Dep.ReaderAdvice.Basic+-- >>> import Control.Monad+-- >>> 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 env m r. (Monad m, Monoid r) => Advice ca env m r+returnMempty =+  makeExecutionAdvice+    ( \action -> do+        _ <- action+        pure (mempty :: r)+    )++-- | Given a 'Handle' and a prefix string, makes functions print their+-- arguments to the 'Handle'.+--+printArgs :: forall env m r. MonadIO m => Handle -> String -> Advice Show env m r+printArgs h prefix =+  makeArgsAdvice+    ( \args -> do+        liftIO $ hPutStr h $ prefix ++ ":"+        hctraverse_ (Proxy @Show) (\(I a) -> liftIO (hPutStr h (" " ++ show a))) args+        liftIO $ hPutStrLn h "\n"+        liftIO $ hFlush h+        pure args+    )+++-- | If the environment carries a 'SyntheticCallStack', make advised functions add+-- themselves to the 'SyntheticCallStack' before they start executing.+--+-- Caught exceptions are rethrown wrapped in 'SyntheticStackTraceException's,+-- with the current 'SyntheticCallStack' added.+keepCallStack ::+  (MonadUnliftIO m, Simple.HasSyntheticCallStack env, 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.ReaderAdvice.adviseRecord'.+  NonEmpty (T.TypeRep, Simple.MethodName) ->+  Advice ca env m r+keepCallStack selector method = makeExecutionAdvice \action -> do+  currentStack <- Simple.askCallStack+  withRunInIO \unlift -> do+    er <- tryJust selector (unlift (Simple.addStackFrame method action))+    case er of+      Left e -> throwIO (Simple.SyntheticStackTraceException (toException e) (method :| currentStack))+      Right r -> pure r

@@ -1,495 +1,495 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE GADTSyntax #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE UndecidableSuperClasses #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE BlockArguments #-}
-
--- | 
---    This module provides the 'Advice' datatype, along for functions for creating,
---    manipulating, composing and applying values of that type.
---
---    'Advice's are type-preserving transformations on effectful functions of
---    any number of arguments.
---
---    For example, assuming we have a record-of-functions like
---
--- >>> :{
---    data Env m = Env {
---      foo :: m ()
---    , bar :: Int -> m (Maybe Char)
---    , baz :: Int -> Bool -> m Char
---    } deriving Generic
---    env :: Env IO
---    env = Env {
---      foo = pure ()
---    , bar = \_ -> pure (Just 'c')
---    , baz = \_ _ -> pure 'i'
---    }
--- :}
---
--- We can modify all the functions in the record in this way:
---
--- >>> :{
---    env' :: Env IO
---    env' = env & advising (adviseRecord @_ @Top \_ -> printArgs stdout "prefix ")
--- :}
---
--- using the 'Control.Monad.Dep.SimpleAdvice.Basic.printArgs' advice. 
---
--- Or modify an individual function in this way:
---
--- >>> :{
---    env' :: Env IO
---    env' = env & advising \env -> env { 
---          bar = advise (printArgs stdout "prefix ") (bar env)
---      } 
--- :}
---
--- __NOTE__:
---
--- This module is an alternative to "Control.Monad.Dep.Advice" with two advantages:
---
--- - It doesn't use 'Control.Monad.Dep.DepT'. The types are simpler because
---   they don't need to refer to 'Control.Monad.Dep.DepT''s environment.
---
--- - Unlike in "Control.Monad.Dep.Advice", we can advise components
---   which work on a fixed concrete monad like 'IO'.
---
--- Compared with "Control.Monad.Dep.Advice", it does require the extra step
--- of invoking the 'advising' helper function on a record-of-functions.
-module Dep.SimpleAdvice
-  ( -- * Preparing components for being advised
-    advising,
-    AspectT (..),
-    -- * The Advice type
-    Advice,
-
-    -- * Creating Advice values
-    makeAdvice,
-    makeArgsAdvice,
-    makeExecutionAdvice,
-
-    -- * Applying Advices
-    advise,
-
-    -- * Harmonizing Advice argument constraints
-    -- $restrict
-    restrictArgs,
-
-    -- * Advising entire records
-    -- $records
-    adviseRecord,
-
-    -- * "sop-core" re-exports
-    -- $sop
-    Top,
-    And,
-    All,
-    NP (..),
-    I (..),
-    cfoldMap_NP,
-    Dict (..),
-  )
-where
-
-import Dep.Has
-import Dep.SimpleAdvice.Internal 
-import Data.Coerce
-import Control.Monad
-import Control.Monad.Fix
-import Data.Functor.Identity
-import Data.Kind
-import Data.List.NonEmpty qualified as N
-import Data.SOP
-import Data.SOP.Dict
-import Data.SOP.NP
-import Data.List.NonEmpty
-import Data.Typeable
-import GHC.Generics qualified as G
-import GHC.TypeLits
-import Control.Applicative
-import Control.Monad.Cont.Class
-import Control.Monad.Error.Class
-import Control.Monad.IO.Unlift
-import Control.Monad.State.Class
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Identity
-import Control.Monad.Writer.Class
-import Control.Monad.Zip
-
--- $setup
---
--- >>> :set -XTypeApplications
--- >>> :set -XStandaloneKindSignatures
--- >>> :set -XMultiParamTypeClasses
--- >>> :set -XFunctionalDependencies
--- >>> :set -XRankNTypes
--- >>> :set -XTypeOperators
--- >>> :set -XConstraintKinds
--- >>> :set -XNamedFieldPuns
--- >>> :set -XFlexibleContexts
--- >>> :set -XDerivingStrategies
--- >>> :set -XGeneralizedNewtypeDeriving
--- >>> :set -XDataKinds
--- >>> :set -XScopedTypeVariables
--- >>> :set -XDeriveGeneric
--- >>> :set -XImportQualifiedPost
--- >>> import Dep.SimpleAdvice
--- >>> import Dep.SimpleAdvice.Basic (printArgs,returnMempty)
--- >>> import Control.Monad
--- >>> import Control.Monad.Trans
--- >>> import Control.Monad.Writer
--- >>> import Data.Kind
--- >>> import Data.SOP
--- >>> import Data.SOP.NP
--- >>> import Data.Monoid
--- >>> import System.IO
--- >>> import Data.IORef
--- >>> import GHC.Generics (Generic)
--- >>> import GHC.Generics qualified
--- >>> import Data.Function
-
-
--- |
---    The most general way of constructing 'Advice's.
---
---    An 'Advice' receives the arguments of the advised
---    function packed into an n-ary product 'NP', performs some 
---    effects based on them, and returns a potentially modified version of the 
---    arguments, along with a function for tweaking the execution of the
---    advised function.
---
--- >>> :{
---  doesNothing :: forall ca m r. Monad m => Advice ca m r
---  doesNothing = makeAdvice (\args -> pure (id, args)) 
--- :}
---
---
-makeAdvice ::
-  forall ca m r.
-    -- | The function that tweaks the arguments and the execution.
-    ( forall as.
-      All ca as =>
-      NP I as ->
-      AspectT m (AspectT m r -> AspectT m r, NP I as)
-    ) ->
-    Advice ca m r
-makeAdvice = Advice
-
--- |
---    Create an advice which only tweaks and/or analyzes the function arguments.
---
--- >>> :{
---  doesNothing :: forall ca m r. Monad m => Advice ca m r
---  doesNothing = makeArgsAdvice pure
--- :}
-makeArgsAdvice ::
-  forall ca m r.
-  Monad m =>
-  -- | The function that tweaks the arguments.
-  ( forall as.
-    All ca as =>
-    NP I as ->
-    AspectT m (NP I as)
-  ) ->
-  Advice ca m r
-makeArgsAdvice tweakArgs =
-  makeAdvice $ \args -> do
-    args' <- tweakArgs args
-    pure (id, args')
-
--- |
---    Create an advice which only tweaks the execution of the final monadic action.
---
--- >>> :{
---  doesNothing :: forall ca m r. Monad m => Advice ca m r
---  doesNothing = makeExecutionAdvice id
--- :}
-makeExecutionAdvice ::
-  forall ca m r.
-  Applicative m =>
-  -- | The function that tweaks the execution.
-  ( AspectT m r ->
-    AspectT m r
-  ) ->
-  Advice ca m r
-makeExecutionAdvice tweakExecution = makeAdvice \args -> pure (tweakExecution, args)
-
-
--- | Apply an 'Advice' to some compatible function. The function must have its
--- effects in 'AspectT', and all of its arguments must satisfy the @ca@ constraint.
---
--- >>> :{
---  foo :: Int -> AspectT IO String
---  foo _ = pure "foo"
---  advisedFoo = advise (printArgs stdout "Foo args: ") foo
--- :}
---
--- __/TYPE APPLICATION REQUIRED!/__ If the @ca@ constraint of the 'Advice' remains polymorphic,
--- it must be supplied by means of a type application:
---
--- >>> :{
---  bar :: Int -> AspectT IO String
---  bar _ = pure "bar"
---  advisedBar1 = advise (returnMempty @Top) bar
---  advisedBar2 = advise @Top returnMempty bar
--- :}
-advise ::
-  forall ca m r as advisee.
-  (Multicurryable as m r advisee, All ca as, Monad m) =>
-  -- | The advice to apply.
-  Advice ca m r ->
-  -- | A function to be adviced.
-  advisee ->
-  advisee
-advise (Advice f) advisee = do
-  let uncurried = multiuncurry @as @m @r advisee
-      uncurried' args = do
-        (tweakExecution, args') <- f args
-        tweakExecution (uncurried args')
-   in multicurry @as @m @r uncurried'
-
--- | This function \"installs\" an 'AspectT' newtype wrapper for the monad
--- parameter of a record-of-functions, applies some function on
--- the tweaked component, and then removes the wrapper from the result.
---
--- This is necessary because the typeclass machinery which handles
--- 'Advice's uses 'AspectT' as a \"mark\" to recognize \"the end of the function\".
-advising 
-    :: Coercible (r_ m) (r_ (AspectT m)) =>
-    -- | transform the record coerced to 'AspectT', for example using 'adviseRecord'
-    (r_ (AspectT m) -> r_ (AspectT m)) ->
-    -- | transform the original record
-    r_ m -> r_ m
-advising f = coerce . f . coerce
-
-type Multicurryable ::
-  [Type] ->
-  (Type -> Type) ->
-  Type ->
-  Type ->
-  Constraint
-class Multicurryable as m r curried | curried -> as m r where
-  multiuncurry :: curried -> NP I as -> AspectT m r
-  multicurry :: (NP I as -> AspectT m r) -> curried
-
-instance Monad m => Multicurryable '[] m r (AspectT m r) where
-  multiuncurry action Nil = action
-  multicurry f = f Nil
-
-instance Multicurryable as m r curried => Multicurryable (a ': as) m r (a -> curried) where
-  multiuncurry f (I a :* as) = multiuncurry @as @m @r @curried (f a) as
-  multicurry f a = multicurry @as @m @r @curried (f . (:*) (I a))
-
--- $restrict
---
---    'Advice' values can be composed using the 'Monoid' instance, but only if
---    they have the same type parameters. It's unfortunate that—unlike with
---    normal function constraints—the @ca@ constraints of an 'Advice' aren't
---    automatically "collected" during composition.
---
---    Instead, we need to harmonize the @ca@ constraints of each 'Advice' by
---    turning them into the combination of all constraints. 'restrictArgs'
---    helps with that.
---
---    'restrictArgs' takes as parameter value-level "\evidence\" that one
---    constraint implies another. But how to construct such evidence? By using
---    the 'Dict' GADT, more precisely the deceptively simple-looking term
---    @\\Dict -> Dict@. That function "absorbs" some constraint present in the
---    ambient context and re-packages it a a new constraint that is implied by
---    the former. We can't rely on type inference here; we need to provide
---    enough type information to the GADT, be it as an explicit signature:
---
--- >>> :{
---  stricterPrintArgs :: forall m r. MonadIO m => Advice (Show `And` Eq `And` Ord) 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 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) ->
-  -- | Advice with less restrictive constraint on the args.
-  Advice less m r ->
-  -- | Advice with more restrictive constraint on the args.
-  Advice more 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
--- come pre-packaged and having a type signature.
--- We arent' so sure about having a signature for a whole composed Advice,
--- because the composition might be done
--- on the fly, while constructing a record, without a top-level binding with a
--- type signature.  This seems to favor putting "more" first.
-restrictArgs evidence (Advice advice) = Advice \args ->
-    let advice' :: forall as. All more as => NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)
-        advice' args' =
-            case Data.SOP.Dict.mapAll @more @less evidence of
-               f -> case f (Dict @(All more) @as) of
-                        Dict -> advice args'
-     in advice' args
-
-
--- advising *all* fields of a record
---
---
-type AdvisedRecord :: (Type -> Constraint) -> (Type -> Type) -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> Constraint
-class AdvisedRecord ca m cr advised where
-  _adviseRecord :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r) -> advised (AspectT m) -> advised (AspectT m)
-
-type AdvisedProduct :: (Type -> Constraint) -> (Type -> Type) -> (Type -> Constraint) -> (k -> Type) -> Constraint
-class AdvisedProduct ca m cr advised_ where
-  _adviseProduct :: TypeRep -> [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r) -> advised_ k -> advised_ k
-
-instance
-  ( G.Generic (advised (AspectT m)),
-    -- G.Rep (advised (AspectT m)) ~ G.D1 ('G.MetaData name mod p nt) (G.C1 y advised_),
-    G.Rep (advised (AspectT m)) ~ G.D1 x (G.C1 y advised_),
-    Typeable advised,
-    AdvisedProduct ca m cr advised_
-  ) =>
-  AdvisedRecord ca m cr advised
-  where
-  _adviseRecord acc f unadvised =
-    let G.M1 (G.M1 unadvised_) = G.from unadvised
-        advised_ = _adviseProduct @_ @ca @m @cr (typeRep (Proxy @advised)) acc f unadvised_
-     in G.to (G.M1 (G.M1 advised_))
-
-instance
-  ( AdvisedProduct ca m cr advised_left,
-    AdvisedProduct ca m cr advised_right
-  ) =>
-  AdvisedProduct ca m cr (advised_left G.:*: advised_right)
-  where
-  _adviseProduct tr acc f (unadvised_left G.:*: unadvised_right) = _adviseProduct @_ @ca @m @cr tr acc f unadvised_left G.:*: _adviseProduct @_ @ca @m @cr tr acc f unadvised_right
-
-data RecordComponent
-  = Terminal
-  | IWrapped
-  | Recurse
-
-type DiscriminateAdvisedComponent :: Type -> RecordComponent
-type family DiscriminateAdvisedComponent c where
-  DiscriminateAdvisedComponent (a -> b) = Terminal
-  DiscriminateAdvisedComponent (AspectT m x) = Terminal
-  DiscriminateAdvisedComponent (Identity _) = IWrapped
-  DiscriminateAdvisedComponent (I _) = IWrapped
-  DiscriminateAdvisedComponent _ = Recurse
-
-type AdvisedComponent :: RecordComponent -> (Type -> Constraint) -> (Type -> Type) -> (Type -> Constraint) -> Type -> Constraint
-class AdvisedComponent component_type ca m cr advised where
-  _adviseComponent :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r) -> advised -> advised
-
-instance
-  ( AdvisedComponent (DiscriminateAdvisedComponent advised) ca m cr advised,
-    KnownSymbol fieldName
-  ) =>
-  AdvisedProduct ca m cr (G.S1 ( 'G.MetaSel ( 'Just fieldName) su ss ds) (G.Rec0 advised))
-  where
-  _adviseProduct tr acc f (G.M1 (G.K1 advised)) =
-    let acc' = (tr, symbolVal (Proxy @fieldName)) : acc
-     in G.M1 (G.K1 (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @m @cr acc' f advised))
-
-instance
-  AdvisedRecord ca m cr advisable =>
-  AdvisedComponent Recurse ca m cr (advisable (AspectT m))
-  where
-  _adviseComponent acc f advised = _adviseRecord @ca @m @cr acc f advised
-
-instance
-  (Multicurryable as m r advised, All ca as, cr r, Monad m) =>
-  AdvisedComponent Terminal ca m cr advised
-  where
-  _adviseComponent acc f advised = advise @ca @m (f (Data.List.NonEmpty.fromList acc)) advised
-
-instance
-  AdvisedComponent (DiscriminateAdvisedComponent advised) ca m cr advised =>
-  AdvisedComponent IWrapped ca m cr (Identity advised)
-  where
-  _adviseComponent acc f (Identity advised) = Identity (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @m @cr acc f advised)
-
-instance
-  AdvisedComponent (DiscriminateAdvisedComponent advised) ca m cr advised =>
-  AdvisedComponent IWrapped ca m cr (I advised)
-  where
-  _adviseComponent acc f (I advised) = I (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @m @cr acc f advised)
-
--- | Gives 'Advice' to all the functions in a record-of-functions.
---
--- The function that builds the advice receives a list of tuples @(TypeRep, String)@
--- which represent the record types and fields names we have
--- traversed until arriving at the advised function. This info can be useful for
--- logging advices. It's a list instead of a single tuple because
--- 'adviseRecord' works recursively. The elements come innermost-first.
---
--- __/TYPE APPLICATION REQUIRED!/__ The @ca@ constraint on function arguments
--- and the @cr@ constraint on the result type must be supplied by means of a
--- type application. Supply 'Top' if no constraint is required.
-adviseRecord ::
-  forall ca cr m advised.
-  AdvisedRecord ca m cr advised =>
-  -- | The advice to apply.
-  (forall r . cr r => NonEmpty (TypeRep, String) -> Advice ca m r) ->
-  -- | The record to advise recursively.
-  advised (AspectT m) ->
-  -- | The advised record.
-  advised (AspectT m)
-adviseRecord = _adviseRecord @ca @m @cr []
-
--- $sop
--- Some useful definitions re-exported the from \"sop-core\" package.
---
--- 'NP' is an n-ary product used to represent the arguments of advised functions.
---
--- 'I' is an identity functor. The arguments processed by an 'Advice' come wrapped in it.
---
--- 'cfoldMap_NP' is useful to construct homogeneous lists out of the 'NP' product, for example:
---
--- >>> cfoldMap_NP (Proxy @Show) (\(I a) -> [show a]) (I False :* I (1::Int) :* Nil)
--- ["False","1"]
-
--- $constraints
---
--- Some useful definitions re-exported the from \"constraints\" package.
---
--- 'Dict' and '(:-)' are GADTs used to capture and transform constraints. Used in the 'restrictArgs' function.
-
--- $constrainthelpers
---
--- To help with the constraint @ca@ that parameterizes 'Advice', this library re-exports the following helpers from \"sop-core\":
---
--- * 'Top' is the \"always satisfied\" constraint, useful when whe don't want to require anything specific in @ca@.
---
--- * 'And' combines two constraints so that an 'Advice' can request them both, for example @Show \`And\` Eq@.
---
--- Also, the 'All' constraint says that some constraint is satisfied by all the
--- components of an 'NP' product. It's in scope when processing the function
--- arguments inside an 'Advice'.
-
--- $invocation
--- These functions are helpers for running 'AspectT' computations, beyond what 'runAspectT' provides.
---
--- They aren't directly related to 'Advice's, but they require some of the same machinery, and that's why they are here.
+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BlockArguments #-}++-- | +--    This module provides the 'Advice' datatype, along for functions for creating,+--    manipulating, composing and applying values of that type.+--+--    'Advice's are type-preserving transformations on effectful functions of+--    any number of arguments.+--+--    For example, assuming we have a record-of-functions like+--+-- >>> :{+--    data Env m = Env {+--      foo :: m ()+--    , bar :: Int -> m (Maybe Char)+--    , baz :: Int -> Bool -> m Char+--    } deriving Generic+--    env :: Env IO+--    env = Env {+--      foo = pure ()+--    , bar = \_ -> pure (Just 'c')+--    , baz = \_ _ -> pure 'i'+--    }+-- :}+--+-- We can modify all the functions in the record in this way:+--+-- >>> :{+--    env' :: Env IO+--    env' = env & advising (adviseRecord @_ @Top \_ -> printArgs stdout "prefix ")+-- :}+--+-- using the 'Control.Monad.Dep.SimpleAdvice.Basic.printArgs' advice. +--+-- Or modify an individual function in this way:+--+-- >>> :{+--    env' :: Env IO+--    env' = env & advising \env -> env { +--          bar = advise (printArgs stdout "prefix ") (bar env)+--      } +-- :}+--+-- __NOTE__:+--+-- This module is an alternative to "Control.Monad.Dep.Advice" with two advantages:+--+-- - It doesn't use 'Control.Monad.Dep.DepT'. The types are simpler because+--   they don't need to refer to 'Control.Monad.Dep.DepT''s environment.+--+-- - Unlike in "Control.Monad.Dep.Advice", we can advise components+--   which work on a fixed concrete monad like 'IO'.+--+-- Compared with "Control.Monad.Dep.Advice", it does require the extra step+-- of invoking the 'advising' helper function on a record-of-functions.+module Dep.SimpleAdvice+  ( -- * Preparing components for being advised+    advising,+    AspectT (..),+    -- * The Advice type+    Advice,++    -- * Creating Advice values+    makeAdvice,+    makeArgsAdvice,+    makeExecutionAdvice,++    -- * Applying Advices+    advise,++    -- * Harmonizing Advice argument constraints+    -- $restrict+    restrictArgs,++    -- * Advising entire records+    -- $records+    adviseRecord,++    -- * "sop-core" re-exports+    -- $sop+    Top,+    And,+    All,+    NP (..),+    I (..),+    cfoldMap_NP,+    Dict (..),+  )+where++import Dep.Has+import Dep.SimpleAdvice.Internal +import Data.Coerce+import Control.Monad+import Control.Monad.Fix+import Data.Functor.Identity+import Data.Kind+import Data.List.NonEmpty qualified as N+import Data.SOP+import Data.SOP.Dict+import Data.SOP.NP+import Data.List.NonEmpty+import Data.Typeable+import GHC.Generics qualified as G+import GHC.TypeLits+import Control.Applicative+import Control.Monad.Cont.Class+import Control.Monad.Error.Class+import Control.Monad.IO.Unlift+import Control.Monad.State.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Identity+import Control.Monad.Writer.Class+import Control.Monad.Zip++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XStandaloneKindSignatures+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XFunctionalDependencies+-- >>> :set -XRankNTypes+-- >>> :set -XTypeOperators+-- >>> :set -XConstraintKinds+-- >>> :set -XNamedFieldPuns+-- >>> :set -XFlexibleContexts+-- >>> :set -XDerivingStrategies+-- >>> :set -XGeneralizedNewtypeDeriving+-- >>> :set -XDataKinds+-- >>> :set -XScopedTypeVariables+-- >>> :set -XDeriveGeneric+-- >>> :set -XImportQualifiedPost+-- >>> import Dep.SimpleAdvice+-- >>> import Dep.SimpleAdvice.Basic (printArgs,returnMempty)+-- >>> import Control.Monad+-- >>> import Control.Monad.Trans+-- >>> import Control.Monad.Writer+-- >>> import Data.Kind+-- >>> import Data.SOP+-- >>> import Data.SOP.NP+-- >>> import Data.Monoid+-- >>> import System.IO+-- >>> import Data.IORef+-- >>> import GHC.Generics (Generic)+-- >>> import GHC.Generics qualified+-- >>> import Data.Function+++-- |+--    The most general way of constructing 'Advice's.+--+--    An 'Advice' receives the arguments of the advised+--    function packed into an n-ary product 'NP', performs some +--    effects based on them, and returns a potentially modified version of the +--    arguments, along with a function for tweaking the execution of the+--    advised function.+--+-- >>> :{+--  doesNothing :: forall ca m r. Monad m => Advice ca m r+--  doesNothing = makeAdvice (\args -> pure (id, args)) +-- :}+--+--+makeAdvice ::+  forall ca m r.+    -- | The function that tweaks the arguments and the execution.+    ( forall as.+      All ca as =>+      NP I as ->+      AspectT m (AspectT m r -> AspectT m r, NP I as)+    ) ->+    Advice ca m r+makeAdvice = Advice++-- |+--    Create an advice which only tweaks and/or analyzes the function arguments.+--+-- >>> :{+--  doesNothing :: forall ca m r. Monad m => Advice ca m r+--  doesNothing = makeArgsAdvice pure+-- :}+makeArgsAdvice ::+  forall ca m r.+  Monad m =>+  -- | The function that tweaks the arguments.+  ( forall as.+    All ca as =>+    NP I as ->+    AspectT m (NP I as)+  ) ->+  Advice ca m r+makeArgsAdvice tweakArgs =+  makeAdvice $ \args -> do+    args' <- tweakArgs args+    pure (id, args')++-- |+--    Create an advice which only tweaks the execution of the final monadic action.+--+-- >>> :{+--  doesNothing :: forall ca m r. Monad m => Advice ca m r+--  doesNothing = makeExecutionAdvice id+-- :}+makeExecutionAdvice ::+  forall ca m r.+  Applicative m =>+  -- | The function that tweaks the execution.+  ( AspectT m r ->+    AspectT m r+  ) ->+  Advice ca m r+makeExecutionAdvice tweakExecution = makeAdvice \args -> pure (tweakExecution, args)+++-- | Apply an 'Advice' to some compatible function. The function must have its+-- effects in 'AspectT', and all of its arguments must satisfy the @ca@ constraint.+--+-- >>> :{+--  foo :: Int -> AspectT IO String+--  foo _ = pure "foo"+--  advisedFoo = advise (printArgs stdout "Foo args: ") foo+-- :}+--+-- __/TYPE APPLICATION REQUIRED!/__ If the @ca@ constraint of the 'Advice' remains polymorphic,+-- it must be supplied by means of a type application:+--+-- >>> :{+--  bar :: Int -> AspectT IO String+--  bar _ = pure "bar"+--  advisedBar1 = advise (returnMempty @Top) bar+--  advisedBar2 = advise @Top returnMempty bar+-- :}+advise ::+  forall ca m r as advisee.+  (Multicurryable as m r advisee, All ca as, Monad m) =>+  -- | The advice to apply.+  Advice ca m r ->+  -- | A function to be adviced.+  advisee ->+  advisee+advise (Advice f) advisee = do+  let uncurried = multiuncurry @as @m @r advisee+      uncurried' args = do+        (tweakExecution, args') <- f args+        tweakExecution (uncurried args')+   in multicurry @as @m @r uncurried'++-- | This function \"installs\" an 'AspectT' newtype wrapper for the monad+-- parameter of a record-of-functions, applies some function on+-- the tweaked component, and then removes the wrapper from the result.+--+-- This is necessary because the typeclass machinery which handles+-- 'Advice's uses 'AspectT' as a \"mark\" to recognize \"the end of the function\".+advising +    :: Coercible (r_ m) (r_ (AspectT m)) =>+    -- | transform the record coerced to 'AspectT', for example using 'adviseRecord'+    (r_ (AspectT m) -> r_ (AspectT m)) ->+    -- | transform the original record+    r_ m -> r_ m+advising f = coerce . f . coerce++type Multicurryable ::+  [Type] ->+  (Type -> Type) ->+  Type ->+  Type ->+  Constraint+class Multicurryable as m r curried | curried -> as m r where+  multiuncurry :: curried -> NP I as -> AspectT m r+  multicurry :: (NP I as -> AspectT m r) -> curried++instance Monad m => Multicurryable '[] m r (AspectT m r) where+  multiuncurry action Nil = action+  multicurry f = f Nil++instance Multicurryable as m r curried => Multicurryable (a ': as) m r (a -> curried) where+  multiuncurry f (I a :* as) = multiuncurry @as @m @r @curried (f a) as+  multicurry f a = multicurry @as @m @r @curried (f . (:*) (I a))++-- $restrict+--+--    'Advice' values can be composed using the 'Monoid' instance, but only if+--    they have the same type parameters. It's unfortunate that—unlike with+--    normal function constraints—the @ca@ constraints of an 'Advice' aren't+--    automatically "collected" during composition.+--+--    Instead, we need to harmonize the @ca@ constraints of each 'Advice' by+--    turning them into the combination of all constraints. 'restrictArgs'+--    helps with that.+--+--    'restrictArgs' takes as parameter value-level "\evidence\" that one+--    constraint implies another. But how to construct such evidence? By using+--    the 'Dict' GADT, more precisely the deceptively simple-looking term+--    @\\Dict -> Dict@. That function "absorbs" some constraint present in the+--    ambient context and re-packages it a a new constraint that is implied by+--    the former. We can't rely on type inference here; we need to provide+--    enough type information to the GADT, be it as an explicit signature:+--+-- >>> :{+--  stricterPrintArgs :: forall m r. MonadIO m => Advice (Show `And` Eq `And` Ord) 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 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) ->+  -- | Advice with less restrictive constraint on the args.+  Advice less m r ->+  -- | Advice with more restrictive constraint on the args.+  Advice more 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+-- come pre-packaged and having a type signature.+-- We arent' so sure about having a signature for a whole composed Advice,+-- because the composition might be done+-- on the fly, while constructing a record, without a top-level binding with a+-- type signature.  This seems to favor putting "more" first.+restrictArgs evidence (Advice advice) = Advice \args ->+    let advice' :: forall as. All more as => NP I as -> AspectT m (AspectT m r -> AspectT m r, NP I as)+        advice' args' =+            case Data.SOP.Dict.mapAll @more @less evidence of+               f -> case f (Dict @(All more) @as) of+                        Dict -> advice args'+     in advice' args+++-- advising *all* fields of a record+--+--+type AdvisedRecord :: (Type -> Constraint) -> (Type -> Type) -> (Type -> Constraint) -> ((Type -> Type) -> Type) -> Constraint+class AdvisedRecord ca m cr advised where+  _adviseRecord :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r) -> advised (AspectT m) -> advised (AspectT m)++type AdvisedProduct :: (Type -> Constraint) -> (Type -> Type) -> (Type -> Constraint) -> (k -> Type) -> Constraint+class AdvisedProduct ca m cr advised_ where+  _adviseProduct :: TypeRep -> [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r) -> advised_ k -> advised_ k++instance+  ( G.Generic (advised (AspectT m)),+    -- G.Rep (advised (AspectT m)) ~ G.D1 ('G.MetaData name mod p nt) (G.C1 y advised_),+    G.Rep (advised (AspectT m)) ~ G.D1 x (G.C1 y advised_),+    Typeable advised,+    AdvisedProduct ca m cr advised_+  ) =>+  AdvisedRecord ca m cr advised+  where+  _adviseRecord acc f unadvised =+    let G.M1 (G.M1 unadvised_) = G.from unadvised+        advised_ = _adviseProduct @_ @ca @m @cr (typeRep (Proxy @advised)) acc f unadvised_+     in G.to (G.M1 (G.M1 advised_))++instance+  ( AdvisedProduct ca m cr advised_left,+    AdvisedProduct ca m cr advised_right+  ) =>+  AdvisedProduct ca m cr (advised_left G.:*: advised_right)+  where+  _adviseProduct tr acc f (unadvised_left G.:*: unadvised_right) = _adviseProduct @_ @ca @m @cr tr acc f unadvised_left G.:*: _adviseProduct @_ @ca @m @cr tr acc f unadvised_right++data RecordComponent+  = Terminal+  | IWrapped+  | Recurse++type DiscriminateAdvisedComponent :: Type -> RecordComponent+type family DiscriminateAdvisedComponent c where+  DiscriminateAdvisedComponent (a -> b) = Terminal+  DiscriminateAdvisedComponent (AspectT m x) = Terminal+  DiscriminateAdvisedComponent (Identity _) = IWrapped+  DiscriminateAdvisedComponent (I _) = IWrapped+  DiscriminateAdvisedComponent _ = Recurse++type AdvisedComponent :: RecordComponent -> (Type -> Constraint) -> (Type -> Type) -> (Type -> Constraint) -> Type -> Constraint+class AdvisedComponent component_type ca m cr advised where+  _adviseComponent :: [(TypeRep, String)] -> (forall r. cr r => NonEmpty (TypeRep, String) -> Advice ca m r) -> advised -> advised++instance+  ( AdvisedComponent (DiscriminateAdvisedComponent advised) ca m cr advised,+    KnownSymbol fieldName+  ) =>+  AdvisedProduct ca m cr (G.S1 ( 'G.MetaSel ( 'Just fieldName) su ss ds) (G.Rec0 advised))+  where+  _adviseProduct tr acc f (G.M1 (G.K1 advised)) =+    let acc' = (tr, symbolVal (Proxy @fieldName)) : acc+     in G.M1 (G.K1 (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @m @cr acc' f advised))++instance+  AdvisedRecord ca m cr advisable =>+  AdvisedComponent Recurse ca m cr (advisable (AspectT m))+  where+  _adviseComponent acc f advised = _adviseRecord @ca @m @cr acc f advised++instance+  (Multicurryable as m r advised, All ca as, cr r, Monad m) =>+  AdvisedComponent Terminal ca m cr advised+  where+  _adviseComponent acc f advised = advise @ca @m (f (Data.List.NonEmpty.fromList acc)) advised++instance+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca m cr advised =>+  AdvisedComponent IWrapped ca m cr (Identity advised)+  where+  _adviseComponent acc f (Identity advised) = Identity (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @m @cr acc f advised)++instance+  AdvisedComponent (DiscriminateAdvisedComponent advised) ca m cr advised =>+  AdvisedComponent IWrapped ca m cr (I advised)+  where+  _adviseComponent acc f (I advised) = I (_adviseComponent @(DiscriminateAdvisedComponent advised) @ca @m @cr acc f advised)++-- | Gives 'Advice' to all the functions in a record-of-functions.+--+-- The function that builds the advice receives a list of tuples @(TypeRep, String)@+-- which represent the record types and fields names we have+-- traversed until arriving at the advised function. This info can be useful for+-- logging advices. It's a list instead of a single tuple because+-- 'adviseRecord' works recursively. The elements come innermost-first.+--+-- __/TYPE APPLICATION REQUIRED!/__ The @ca@ constraint on function arguments+-- and the @cr@ constraint on the result type must be supplied by means of a+-- type application. Supply 'Top' if no constraint is required.+adviseRecord ::+  forall ca cr m advised.+  AdvisedRecord ca m cr advised =>+  -- | The advice to apply.+  (forall r . cr r => NonEmpty (TypeRep, String) -> Advice ca m r) ->+  -- | The record to advise recursively.+  advised (AspectT m) ->+  -- | The advised record.+  advised (AspectT m)+adviseRecord = _adviseRecord @ca @m @cr []++-- $sop+-- Some useful definitions re-exported the from \"sop-core\" package.+--+-- 'NP' is an n-ary product used to represent the arguments of advised functions.+--+-- 'I' is an identity functor. The arguments processed by an 'Advice' come wrapped in it.+--+-- 'cfoldMap_NP' is useful to construct homogeneous lists out of the 'NP' product, for example:+--+-- >>> cfoldMap_NP (Proxy @Show) (\(I a) -> [show a]) (I False :* I (1::Int) :* Nil)+-- ["False","1"]++-- $constraints+--+-- Some useful definitions re-exported the from \"constraints\" package.+--+-- 'Dict' and '(:-)' are GADTs used to capture and transform constraints. Used in the 'restrictArgs' function.++-- $constrainthelpers+--+-- To help with the constraint @ca@ that parameterizes 'Advice', this library re-exports the following helpers from \"sop-core\":+--+-- * 'Top' is the \"always satisfied\" constraint, useful when whe don't want to require anything specific in @ca@.+--+-- * 'And' combines two constraints so that an 'Advice' can request them both, for example @Show \`And\` Eq@.+--+-- Also, the 'All' constraint says that some constraint is satisfied by all the+-- components of an 'NP' product. It's in scope when processing the function+-- arguments inside an 'Advice'.++-- $invocation+-- These functions are helpers for running 'AspectT' computations, beyond what 'runAspectT' provides.+--+-- They aren't directly related to 'Advice's, but they require some of the same machinery, and that's why they are here.

@@ -1,273 +1,273 @@-{-# 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 =
-  makeExecutionAdvice
-    ( \action -> do
-        _ <- action
-        pure (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 h prefix =
-  makeArgsAdvice
-    ( \args -> do
-        liftIO $ hPutStr h $ prefix ++ ":"
-        hctraverse_ (Proxy @Show) (\(I a) -> liftIO (hPutStr h (" " ++ show a))) args
-        liftIO $ hPutStrLn h "\n"
-        liftIO $ hFlush h
-        pure 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 any1 == AnyEq any2 =
-    case testEquality (typeOf any1) (typeOf any2) of
-      Nothing -> False
-      Just Refl -> any1 == 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 cacheLookup cachePut = makeAdvice \args ->
-        let key = AnyEq $ cfoldMap_NP (Proxy @(And Eq Typeable)) (\(I a) -> [AnyEq a]) $ args
-            tweakExecution action = do
-                mr <- lift $ cacheLookup key
-                case mr of
-                  Nothing -> do
-                    r <- action
-                    lift $ cachePut key r
-                    pure r
-                  Just r ->
-                    pure r
-         in pure (tweakExecution, 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 = makeExecutionAdvice \action -> do
-    _ <- withRunInIO (\unlift -> forkIO (unlift action))
-    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 ref = makeExecutionAdvice \action -> do
-    (before, after) <- liftIO $ atomicModifyIORef' ref \(before : befores, after : afters) -> ((befores, afters), (before, after))
-    liftIO before
-    r <- action
-    liftIO after
-    pure 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 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 = 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
-    -- | 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 = id
-
-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
--- 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 selector method = makeExecutionAdvice \action -> do
-  currentStack <- askCallStack
-  withRunInIO \unlift -> do
-    er <- tryJust selector (unlift (addStackFrame method action))
-    case er of
-      Left e -> throwIO (SyntheticStackTraceException (toException e) (method :| currentStack))
-      Right r -> pure r
-
-
-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)
-
+{-# 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 =+  makeExecutionAdvice+    ( \action -> do+        _ <- action+        pure (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 h prefix =+  makeArgsAdvice+    ( \args -> do+        liftIO $ hPutStr h $ prefix ++ ":"+        hctraverse_ (Proxy @Show) (\(I a) -> liftIO (hPutStr h (" " ++ show a))) args+        liftIO $ hPutStrLn h "\n"+        liftIO $ hFlush h+        pure 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 any1 == AnyEq any2 =+    case testEquality (typeOf any1) (typeOf any2) of+      Nothing -> False+      Just Refl -> any1 == 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 cacheLookup cachePut = makeAdvice \args ->+        let key = AnyEq $ cfoldMap_NP (Proxy @(And Eq Typeable)) (\(I a) -> [AnyEq a]) $ args+            tweakExecution action = do+                mr <- lift $ cacheLookup key+                case mr of+                  Nothing -> do+                    r <- action+                    lift $ cachePut key r+                    pure r+                  Just r ->+                    pure r+         in pure (tweakExecution, 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 = makeExecutionAdvice \action -> do+    _ <- withRunInIO (\unlift -> forkIO (unlift action))+    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 ref = makeExecutionAdvice \action -> do+    (before, after) <- liftIO $ atomicModifyIORef' ref \(before : befores, after : afters) -> ((befores, afters), (before, after))+    liftIO before+    r <- action+    liftIO after+    pure 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 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 = 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+    -- | 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 = id++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+-- 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 selector method = makeExecutionAdvice \action -> do+  currentStack <- askCallStack+  withRunInIO \unlift -> do+    er <- tryJust selector (unlift (addStackFrame method action))+    case er of+      Left e -> throwIO (SyntheticStackTraceException (toException e) (method :| currentStack))+      Right r -> pure r+++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)+

@@ -1,126 +1,126 @@-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE GADTSyntax #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE UndecidableSuperClasses #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE BlockArguments #-}
-
-module Dep.SimpleAdvice.Internal where
-
-import Dep.Has
-import Data.Coerce
-import Control.Monad
-import Control.Monad.Fix
-import Data.Functor.Identity
-import Data.Kind
-import Data.List.NonEmpty qualified as N
-import Data.SOP
-import Data.SOP.Dict
-import Data.SOP.NP
-import Data.Typeable
-import GHC.Generics qualified as G
-import GHC.TypeLits
-import Control.Applicative
-import Control.Monad.Reader
-import Control.Monad.Cont.Class
-import Control.Monad.Error.Class
-import Control.Monad.IO.Unlift
-import Control.Monad.State.Class
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Identity
-import Control.Monad.Writer.Class
-import Control.Monad.Zip
-
--- | A generic transformation of 'AspectT'-effectful functions with 
--- base monad @m@ and return type @r@,
--- provided the functions satisfy certain constraint @ca@
--- on all of their arguments.
---
--- 'Advice's that don't care about the @ca@ constraint (because they don't
--- touch function arguments) can leave it polymorphic, and this facilitates
--- 'Advice' composition, but then the constraint must be given the catch-all
--- `Top` value (using a type application) at the moment of calling 'advise'.
---
--- See "Control.Monad.Dep.SimpleAdvice.Basic" for examples.
-type Advice ::
-  (Type -> Constraint) ->
-  (Type -> Type) ->
-  Type ->
-  Type
-data Advice (ca :: Type -> Constraint) m r where
-  Advice ::
-    forall ca 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
-
-
--- |
---    'Advice's compose \"sequentially\" when tweaking the arguments, and
---    \"concentrically\" when tweaking the final 'AspectT' 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 m r) where
-  Advice outer <> Advice inner = Advice \args -> do
-    (tweakOuter, argsOuter) <- outer args
-    (tweakInner, argsInner) <- inner argsOuter
-    pure (tweakOuter . tweakInner, argsInner)
-
-instance Monad m => Monoid (Advice ca m r) where
-  mappend = (<>)
-  mempty = Advice \args -> pure (id, args)
-
-
--- | This transformer is isomorphic to 'Control.Monad.Trans.Identity.IdentityT'.
---
--- It doesn't really do anything, it only helps the typeclass machinery.
-type AspectT ::
-  (Type -> Type) ->
-  Type ->
-  Type
-newtype AspectT (m :: Type -> Type) (r :: Type) = AspectT {runAspectT :: m r}
-  deriving
-    ( Functor,
-      Applicative,
-      Alternative,
-      Monad,
-      MonadFix,
-      MonadFail,
-      MonadZip,
-      MonadPlus,
-      MonadCont,
-      MonadIO,
-      MonadUnliftIO
-    )
-
-instance MonadTrans AspectT where
-  lift = AspectT 
-
-deriving newtype instance MonadReader env m => MonadReader env (AspectT m)
-deriving newtype instance MonadState s m => MonadState s (AspectT m)
-deriving newtype instance MonadWriter w m => MonadWriter w (AspectT m)
-deriving newtype instance MonadError e m => MonadError e (AspectT m)
-
-data Pair a b = Pair !a !b
-
+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE BlockArguments #-}++module Dep.SimpleAdvice.Internal where++import Dep.Has+import Data.Coerce+import Control.Monad+import Control.Monad.Fix+import Data.Functor.Identity+import Data.Kind+import Data.List.NonEmpty qualified as N+import Data.SOP+import Data.SOP.Dict+import Data.SOP.NP+import Data.Typeable+import GHC.Generics qualified as G+import GHC.TypeLits+import Control.Applicative+import Control.Monad.Reader+import Control.Monad.Cont.Class+import Control.Monad.Error.Class+import Control.Monad.IO.Unlift+import Control.Monad.State.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Identity+import Control.Monad.Writer.Class+import Control.Monad.Zip++-- | A generic transformation of 'AspectT'-effectful functions with +-- base monad @m@ and return type @r@,+-- provided the functions satisfy certain constraint @ca@+-- on all of their arguments.+--+-- 'Advice's that don't care about the @ca@ constraint (because they don't+-- touch function arguments) can leave it polymorphic, and this facilitates+-- 'Advice' composition, but then the constraint must be given the catch-all+-- `Top` value (using a type application) at the moment of calling 'advise'.+--+-- See "Control.Monad.Dep.SimpleAdvice.Basic" for examples.+type Advice ::+  (Type -> Constraint) ->+  (Type -> Type) ->+  Type ->+  Type+data Advice (ca :: Type -> Constraint) m r where+  Advice ::+    forall ca 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+++-- |+--    'Advice's compose \"sequentially\" when tweaking the arguments, and+--    \"concentrically\" when tweaking the final 'AspectT' 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 m r) where+  Advice outer <> Advice inner = Advice \args -> do+    (tweakOuter, argsOuter) <- outer args+    (tweakInner, argsInner) <- inner argsOuter+    pure (tweakOuter . tweakInner, argsInner)++instance Monad m => Monoid (Advice ca m r) where+  mappend = (<>)+  mempty = Advice \args -> pure (id, args)+++-- | This transformer is isomorphic to 'Control.Monad.Trans.Identity.IdentityT'.+--+-- It doesn't really do anything, it only helps the typeclass machinery.+type AspectT ::+  (Type -> Type) ->+  Type ->+  Type+newtype AspectT (m :: Type -> Type) (r :: Type) = AspectT {runAspectT :: m r}+  deriving+    ( Functor,+      Applicative,+      Alternative,+      Monad,+      MonadFix,+      MonadFail,+      MonadZip,+      MonadPlus,+      MonadCont,+      MonadIO,+      MonadUnliftIO+    )++instance MonadTrans AspectT where+  lift = AspectT ++deriving newtype instance MonadReader env m => MonadReader env (AspectT m)+deriving newtype instance MonadState s m => MonadState s (AspectT m)+deriving newtype instance MonadWriter w m => MonadWriter w (AspectT m)+deriving newtype instance MonadError e m => MonadError e (AspectT m)++data Pair a b = Pair !a !b+

@@ -1,12 +1,16 @@-module Main (main) where
-
-import Test.DocTest
-
-main =
-  doctest
-    [ "-ilib",
-      "lib/Dep/Advice.hs"
-    , "lib/Dep/Advice/Basic.hs"
-    , "lib/Dep/SimpleAdvice.hs"
-    , "lib/Dep/SimpleAdvice/Basic.hs"
-    ]
+module Main (main) where++import Test.DocTest++main =+  doctest+    [ "-ilib",+      "lib/Dep/Advice.hs"+    , "lib/Dep/Advice/Basic.hs"+    , "lib/Dep/SimpleAdvice.hs"+    , "lib/Dep/SimpleAdvice/Basic.hs"+    , "lib/Dep/ReaderAdvice.hs"+    , "lib/Dep/ReaderAdvice/Basic.hs"+    , "lib/Dep/IOAdvice.hs"+    , "lib/Dep/IOAdvice/Basic.hs"+    ]

@@ -1,178 +1,178 @@-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE BlockArguments #-}
-
-module Main (main) where
-
-import Prelude hiding (log)
-import Barbies
-import Dep.Has
-import Dep.SimpleAdvice
-import Dep.SimpleAdvice.Basic
-import Control.Monad.Dep
-import Control.Monad.Reader
-import Control.Monad.Writer
-import Data.List.NonEmpty 
-import Data.Typeable
-import Data.Coerce
-import Data.Functor.Identity
-import Data.Kind
-import Data.List (intercalate)
-import Data.SOP
-import GHC.Generics
-import Test.Tasty
-import Test.Tasty.HUnit
-import Data.IORef
-import System.IO
-
-printArgs' :: forall m r. MonadIO m => Handle -> String -> Advice (Show `And` Eq) m r
-printArgs' h s = restrictArgs (\Dict -> Dict) (printArgs h s) 
-
--- the "component" we want to decorate
-data Foo m = Foo { 
-        runFoo :: Int -> Bool -> m () 
-    ,   runBar :: m Int
-    ,   runBaz :: Char -> m Char
-    } 
-    deriving stock Generic
-
-fooFunc :: MonadWriter [String] m => Int -> Bool -> m ()  
-fooFunc = \_ _ -> tell ["foo"] 
-
-foo :: MonadWriter [String] m => Foo m
-foo = Foo fooFunc (pure 5) (\_ -> pure 'c')
-
--- works with functions of any number of arguments
-someAdvice :: MonadWriter [String] m => Advice Top m r 
-someAdvice = makeExecutionAdvice \action -> do
-    tell ["before"]
-    r <- action
-    tell ["after"]
-    pure r
-
-someAdvice' :: MonadWriter [String] m => Advice Top m r 
-someAdvice' = 
-    (makeExecutionAdvice \action -> do
-        r <- action
-        tell ["after"]
-        pure r)
-    <>
-    (makeExecutionAdvice \action -> do
-        tell ["before"]
-        r <- action
-        pure r)
-
-advisedFoo :: MonadWriter [String] m => Foo m
-advisedFoo = advising (adviseRecord @Top @Top \_ -> someAdvice) foo
-
--- Unlike regular advices, which require decorated
--- functions to be sufficiently polymorphic,
--- "simple" advices can decorate
--- non-DepT *concrete* monads.
-concreteFoo :: IORef [String] -> Foo IO
-concreteFoo ref = Foo {
-        runFoo = \_ _ -> modifyIORef ref (\xs -> xs ++ ["foo"])
-    ,   runBar = pure 5
-    ,   runBaz = \_ -> pure 'c'
-    }
-
-refAdvice :: MonadIO m => IORef [String] -> Advice Top m r 
-refAdvice ref = makeExecutionAdvice \action -> do
-    liftIO $ modifyIORef ref (\xs -> xs ++ ["before"])
-    r <- action
-    liftIO $ modifyIORef ref (\xs -> xs ++ ["after"])
-    pure r
-
-concreteAdvisedFoo :: IORef [String] -> Foo IO
-concreteAdvisedFoo ref =
-    advising (adviseRecord @Top @Top \_ -> refAdvice ref) (concreteFoo ref)
-
-printAdvisedFoo :: IORef [String] -> Foo IO
-printAdvisedFoo ref =
-    advising (adviseRecord @_ @Top (\_ -> printArgs' stdout "args: ")) (concreteFoo ref)
-
---
--- Stuff for testing the TypeReps in adviseRecord
-data AAA m = AAA { aaa :: BBB m } deriving Generic
--- just to check that newtypes are handled correctly
-newtype BBB m = BBB { bbb :: CCC m } deriving Generic 
-data CCC m = CCC { ccc :: Int -> Bool ->  m () } deriving Generic
-
-type Trace = Writer [(TypeRep, String)]
-
-tracedEnv :: AAA Trace
-tracedEnv = AAA {
-        aaa = BBB {
-            bbb = CCC { 
-               ccc = \_ _ -> pure () 
-            }
-        }
-    }
-
-doTrace :: NonEmpty (TypeRep, String) -> Advice ca Trace r
-doTrace trace = makeExecutionAdvice \action -> do
-    tell (toList trace) 
-    action
-
---
---
-tests :: TestTree
-tests =
-  testGroup
-    "All"
-    [
-      testCase "adviseBare" $
-        assertEqual "" ["before","foo","after"] $
-            let advisedFunc = advise @Top someAdvice fooFunc
-             in execWriter $ runAspectT $ advisedFunc 0 False
-    , testCase "adviseBare_monoid" $
-        assertEqual "" ["before","foo","after"] $
-            let advisedFunc = advise @Top someAdvice' fooFunc
-             in execWriter $ runAspectT $ advisedFunc 0 False
-    , testCase "adviseRecord" $
-        assertEqual "" ["before","foo","after"] $
-          let advised = advising (adviseRecord @Top @Top \_ -> someAdvice) foo
-           in execWriter $ runFoo advised 0 False
-    , testCase "concrete adviseRecord" $ do
-        ref <- newIORef []
-        () <- runFoo (concreteAdvisedFoo ref) 0 False
-        result <- readIORef ref
-        assertEqual "" ["before","foo","after"] result
-    , testCase "print adviseRecord" $ do
-        ref <- newIORef []
-        () <- runFoo (printAdvisedFoo ref) 0 False
-        result <- readIORef ref
-        assertEqual "" ["foo"] result
-    , testCase "trace" $ do
-        let tracedEnv' = advising (adviseRecord @Top @Top doTrace) tracedEnv
-            result = execWriter $ (ccc . bbb . aaa) tracedEnv' 0 False
-            expected = [
-                  (typeRep (Proxy @CCC), "ccc")
-                , (typeRep (Proxy @BBB), "bbb")
-                , (typeRep (Proxy @AAA), "aaa")
-                ]
-        assertEqual "" expected result
-    ]
-
-main :: IO ()
-main = defaultMain tests
+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BlockArguments #-}++module Main (main) where++import Prelude hiding (log)+import Barbies+import Dep.Has+import Dep.SimpleAdvice+import Dep.SimpleAdvice.Basic+import Control.Monad.Dep+import Control.Monad.Reader+import Control.Monad.Writer+import Data.List.NonEmpty +import Data.Typeable+import Data.Coerce+import Data.Functor.Identity+import Data.Kind+import Data.List (intercalate)+import Data.SOP+import GHC.Generics+import Test.Tasty+import Test.Tasty.HUnit+import Data.IORef+import System.IO++printArgs' :: forall m r. MonadIO m => Handle -> String -> Advice (Show `And` Eq) m r+printArgs' h s = restrictArgs (\Dict -> Dict) (printArgs h s) ++-- the "component" we want to decorate+data Foo m = Foo { +        runFoo :: Int -> Bool -> m () +    ,   runBar :: m Int+    ,   runBaz :: Char -> m Char+    } +    deriving stock Generic++fooFunc :: MonadWriter [String] m => Int -> Bool -> m ()  +fooFunc = \_ _ -> tell ["foo"] ++foo :: MonadWriter [String] m => Foo m+foo = Foo fooFunc (pure 5) (\_ -> pure 'c')++-- works with functions of any number of arguments+someAdvice :: MonadWriter [String] m => Advice Top m r +someAdvice = makeExecutionAdvice \action -> do+    tell ["before"]+    r <- action+    tell ["after"]+    pure r++someAdvice' :: MonadWriter [String] m => Advice Top m r +someAdvice' = +    (makeExecutionAdvice \action -> do+        r <- action+        tell ["after"]+        pure r)+    <>+    (makeExecutionAdvice \action -> do+        tell ["before"]+        r <- action+        pure r)++advisedFoo :: MonadWriter [String] m => Foo m+advisedFoo = advising (adviseRecord @Top @Top \_ -> someAdvice) foo++-- Unlike regular advices, which require decorated+-- functions to be sufficiently polymorphic,+-- "simple" advices can decorate+-- non-DepT *concrete* monads.+concreteFoo :: IORef [String] -> Foo IO+concreteFoo ref = Foo {+        runFoo = \_ _ -> modifyIORef ref (\xs -> xs ++ ["foo"])+    ,   runBar = pure 5+    ,   runBaz = \_ -> pure 'c'+    }++refAdvice :: MonadIO m => IORef [String] -> Advice Top m r +refAdvice ref = makeExecutionAdvice \action -> do+    liftIO $ modifyIORef ref (\xs -> xs ++ ["before"])+    r <- action+    liftIO $ modifyIORef ref (\xs -> xs ++ ["after"])+    pure r++concreteAdvisedFoo :: IORef [String] -> Foo IO+concreteAdvisedFoo ref =+    advising (adviseRecord @Top @Top \_ -> refAdvice ref) (concreteFoo ref)++printAdvisedFoo :: IORef [String] -> Foo IO+printAdvisedFoo ref =+    advising (adviseRecord @_ @Top (\_ -> printArgs' stdout "args: ")) (concreteFoo ref)++--+-- Stuff for testing the TypeReps in adviseRecord+data AAA m = AAA { aaa :: BBB m } deriving Generic+-- just to check that newtypes are handled correctly+newtype BBB m = BBB { bbb :: CCC m } deriving Generic +data CCC m = CCC { ccc :: Int -> Bool ->  m () } deriving Generic++type Trace = Writer [(TypeRep, String)]++tracedEnv :: AAA Trace+tracedEnv = AAA {+        aaa = BBB {+            bbb = CCC { +               ccc = \_ _ -> pure () +            }+        }+    }++doTrace :: NonEmpty (TypeRep, String) -> Advice ca Trace r+doTrace trace = makeExecutionAdvice \action -> do+    tell (toList trace) +    action++--+--+tests :: TestTree+tests =+  testGroup+    "All"+    [+      testCase "adviseBare" $+        assertEqual "" ["before","foo","after"] $+            let advisedFunc = advise @Top someAdvice fooFunc+             in execWriter $ runAspectT $ advisedFunc 0 False+    , testCase "adviseBare_monoid" $+        assertEqual "" ["before","foo","after"] $+            let advisedFunc = advise @Top someAdvice' fooFunc+             in execWriter $ runAspectT $ advisedFunc 0 False+    , testCase "adviseRecord" $+        assertEqual "" ["before","foo","after"] $+          let advised = advising (adviseRecord @Top @Top \_ -> someAdvice) foo+           in execWriter $ runFoo advised 0 False+    , testCase "concrete adviseRecord" $ do+        ref <- newIORef []+        () <- runFoo (concreteAdvisedFoo ref) 0 False+        result <- readIORef ref+        assertEqual "" ["before","foo","after"] result+    , testCase "print adviseRecord" $ do+        ref <- newIORef []+        () <- runFoo (printAdvisedFoo ref) 0 False+        result <- readIORef ref+        assertEqual "" ["foo"] result+    , testCase "trace" $ do+        let tracedEnv' = advising (adviseRecord @Top @Top doTrace) tracedEnv+            result = execWriter $ (ccc . bbb . aaa) tracedEnv' 0 False+            expected = [+                  (typeRep (Proxy @CCC), "ccc")+                , (typeRep (Proxy @BBB), "bbb")+                , (typeRep (Proxy @AAA), "aaa")+                ]+        assertEqual "" expected result+    ]++main :: IO ()+main = defaultMain tests

@@ -1,548 +1,548 @@-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ImportQualifiedPost #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE ViewPatterns #-}
-
--- | 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
--- injection.
---
--- We are assuming that the application follows a "record-of-functions" style.
-module Main (main) where
-
-import Control.Exception
-import Control.Monad.Dep (DepT)
-import Control.Monad.IO.Unlift
-import Control.Monad.Reader
-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
-import Data.IORef
-import Data.List.NonEmpty (NonEmpty (..))
-import Data.List.NonEmpty qualified as NonEmpty
-import Data.Set (Set)
-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 (..),
-    Constructor,
-    DemotableFieldNames,
-    FieldsFindableByType,
-    Phased,
-    bindPhase,
-    constructor,
-    fixEnv,
-    pullPhase,
-    skipPhase,
-  )
-import Dep.Has
-  ( Has (dep),
-    asCall,
-  )
-import Dep.Tagged (Tagged (..), tagged, untag)
-import Dep.SimpleAdvice
-  ( Advice,
-    AspectT (..),
-    Top,
-    adviseRecord,
-    advising,
-    makeExecutionAdvice,
-  )
-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
---
---
-
--- Component interfaces, defined as records polymorphic over the effect monad.
-newtype Logger m = Logger
-  { emitMsg :: String -> m ()
-  }
-  deriving stock (Generic)
-
-data Repository m = Repository
-  { insert :: Int -> m (),
-    lookup :: Int -> m Bool
-  }
-  deriving stock (Generic)
-
-newtype Controller m = Controller
-  { -- insert one arg, look up the other. Nonsensical, but good enough for an example.
-    route :: Int -> Int -> m Bool
-  }
-  deriving stock (Generic)
-
--- Component implementations, some of which depend on other components.
---
-makeStdoutLogger :: MonadIO m => Logger m
-makeStdoutLogger = Logger \msg -> liftIO $ putStrLn msg
-
--- allocation helper.
-allocateSet :: Allocator (IORef (Set Int))
-allocateSet = ContT $ bracket (newIORef Set.empty) pure
-
--- When a component depends on another, it does so by taking an "env" parameter
--- in the constructor and requiring 'Has' constraints on it.
-makeInMemoryRepository ::
-  (Has Logger m env, MonadIO m) =>
-  IORef (Set Int) ->
-  env ->
-  Repository m
-makeInMemoryRepository ref (asCall -> call) = do
-  Repository
-    { insert = \key -> do
-        call emitMsg "inserting..."
-        theSet <- liftIO $ readIORef ref
-        liftIO $ writeIORef ref $ Set.insert key theSet,
-      lookup = \key -> do
-        call emitMsg "looking..."
-        theSet <- liftIO $ readIORef ref
-        pure (Set.member key theSet)
-    }
-
--- This implementation of Controller depends both on the Logger and the
--- Repository.
---
--- In general, the graph of dependencies between components can be a complex
--- directed acyclic graph.
-makeController ::
-  (Has Logger m env, Has Repository m env, Monad m) =>
-  env ->
-  Controller m
-makeController (asCall -> call) =
-  Controller
-    { route = \toInsert toLookup -> do
-        call emitMsg "serving..."
-        call insert toInsert
-        call emitMsg "before lookup..."
-        call lookup toLookup
-    }
-
-type MakeController2LoggersDeps = '[Logger, Tagged "secondary" Logger, Repository]
-makeController2Loggers :: 
-  (HasAll MakeController2LoggersDeps 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.
---
--- We put all the components which will form part of our application in an
--- environment record.
---
--- Each field is wrapped in a functor `h` which controls the "phases" we must
--- go through in  the construction of the environment. When `h` becomes
--- Identity, the environment is ready for use. (This is an example of the
--- "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)
-  }
-  deriving stock (Generic)
-  deriving anyclass (Phased, DemotableFieldNames, FieldsFindableByType)
-
--- Locate the components by their types. We could also define the required Has
--- instance for each component manually, but that's tedious.
-deriving via Autowired (Env Identity m) instance Autowireable r_ m (Env Identity m) => Has r_ m (Env Identity m)
-
--- The "phases" that components go through until fully built. Each phase
--- is represented as an applicative functor. The succession of phases is
--- defined using Data.Functor.Compose.
---
-
--- A phase in which we might allocate some resource needed by the component,
--- also set some bracket-like resource management.
--- The "managed" library could be used instead of ContT.
-type Allocator = ContT () IO
-
--- First we allocate any needed resource, then we have a construction phase
--- during which the component reads its own dependencies from a "completed"
--- environment.
---
--- There could be more phases, like for example an initial "read configuration"
--- phase.
-type Phases env = Allocator `Compose` Constructor env
-
--- Environment value
---
--- The base monad is a 'ReaderT' holding a SyntheticCallStack value which gets modified
--- using "local" for each sub-call.
---
--- Notice that neither the interfaces nor the implementations which we defined
--- earlier knew anything about the ReaderT.
-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
-                ),
-      logger2 =
-        allocateBombs 0 `bindPhase` \bombs ->
-          constructor \_ ->
-            tagged @"secondary" makeStdoutLogger
-              & advising
-                ( adviseRecord @Top @Top \method ->
-                    keepCallStack ioEx method <> injectFailures bombs
-                ),
-      repository =
-        allocateSet `bindPhase` \ref ->
-          constructor \env ->
-            makeInMemoryRepository ref env
-              & advising
-                ( adviseRecord @Top @Top \method ->
-                    keepCallStack ioEx method
-                ),
-      controller =
-        skipPhase @Allocator $
-          constructor \env ->
-            makeController env
-              & advising
-                ( adviseRecord @Top @Top \method ->
-                    keepCallStack ioEx method
-                )
-    }
-
--- Catch only IOExceptions for this example.
-ioEx :: SomeException -> Maybe IOError
-ioEx = fromException @IOError
-
--- Allocate a supply of potentially exception-throwing actions.
-allocateBombs :: Int -> Allocator (IORef ([IO ()], [IO ()]))
-allocateBombs whenToBomb = ContT $ bracket (newIORef bombs) pure
-  where
-    bombs =
-      ( replicate whenToBomb (pure ()) ++ repeat (throwIO (userError "oops")),
-        repeat (pure ())
-      )
-
--- THE COMPOSITION ROOT - ALTERNATIVE APPROACH
---
---
--- Here we'll define the dependency injection environment in a slightly
--- different way (but reusing both the "business logic" and the Env type).
-
--- The basic idea is that we don't perform dependency injection as a separate
--- Applicative phase (so no Constructor, but a mere Identity phase).
---
--- Instead, we shift that task into the base monad's environent.
-
--- As a result the "phases" are simpler:
-type Phases' = Allocator `Compose` Identity
-
--- Now the expanded "runtime" environment will hold both the synthetic call
--- stack and the components. We define this small helper datatype for that. It
--- augments a preexisting environment with call-related info.
-data CallEnv i e_ m = CallEnv
-  { _callInfo :: i,
-    _ops :: e_ m
-  }
-
--- Delegate all 'Has' queries to the inner environment.
-instance Has r_ m (e_ m) => Has r_ m (CallEnv i e_ m) where
-  dep = dep . _ops
-
-instance HasSyntheticCallStack (CallEnv SyntheticCallStack e_ m) where
-  callStack = lens _callInfo (\(CallEnv _ ops) i' -> CallEnv i' ops)
-
--- Here use the DepT monad (a variant of ReaderT) as the base monad.
---
--- 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
--- components.
-env' :: Env Phases' (DepT (CallEnv SyntheticCallStack (Env Identity)) IO)
-env' =
-  Env
-    { logger =
-        allocateBombs 1 `bindPhase` \bombs ->
-          Identity $ A.component \_ ->
-            makeStdoutLogger
-              & A.adviseRecord @Top @Top \method ->
-                A.keepCallStack ioEx method <> A.injectFailures bombs,
-      logger2 =
-        allocateBombs 0 `bindPhase` \bombs ->
-          Identity $ A.component \_ ->
-            tagged @"secondary" makeStdoutLogger
-              & A.adviseRecord @Top @Top \method ->
-                A.keepCallStack ioEx method <> A.injectFailures bombs,
-      repository =
-        allocateSet `bindPhase` \ref ->
-          Identity $ A.component \env ->
-            makeInMemoryRepository ref env
-              & A.adviseRecord @Top @Top \method ->
-                A.keepCallStack ioEx method,
-      controller =
-        skipPhase @Allocator $
-          Identity $ A.component \env ->
-            makeController env
-              & A.adviseRecord @Top @Top \method ->
-                A.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 Constant, which makes DepT
--- behave almost as a regular ReaderT.
--- 
--- 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 (Constant 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.keepCallStack ioEx method <> A.injectFailures bombs,
-      logger2 =
-        allocateBombs 0 `bindPhase` \bombs ->
-           constructor \_ ->
-            tagged @"secondary" makeStdoutLogger
-              & A.adviseRecord @Top @Top \method ->
-                A.keepCallStack ioEx method <> A.injectFailures bombs,
-      repository =
-        allocateSet `bindPhase` \ref ->
-          constructor \env ->
-            makeInMemoryRepository ref env
-              & A.adviseRecord @Top @Top \method ->
-                A.keepCallStack ioEx method,
-      controller =
-        skipPhase @Allocator $
-          constructor \env ->
-            makeController env
-              & A.adviseRecord @Top @Top \method ->
-                A.keepCallStack ioEx method
-    }
-
--- TESTS
---
---
-expectedException :: (IOError, SyntheticStackTrace)
-expectedException =
-  ( userError "oops",
-    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
-          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" 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
-  let action =
-        runContT (pullPhase @Allocator env') \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" 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.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 (Constant [])) (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.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 (Constant [])) (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 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 ()
-main = defaultMain tests
+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- | 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+-- injection.+--+-- We are assuming that the application follows a "record-of-functions" style.+module Main (main) where++import Control.Exception+import Control.Monad.Dep (DepT)+import Control.Monad.IO.Unlift+import Control.Monad.Reader+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+import Data.IORef+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Set (Set)+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 (..),+    Constructor,+    DemotableFieldNames,+    FieldsFindableByType,+    Phased,+    bindPhase,+    constructor,+    fixEnv,+    pullPhase,+    skipPhase,+  )+import Dep.Has+  ( Has (dep),+    asCall,+  )+import Dep.Tagged (Tagged (..), tagged, untag)+import Dep.SimpleAdvice+  ( Advice,+    AspectT (..),+    Top,+    adviseRecord,+    advising,+    makeExecutionAdvice,+  )+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+--+--++-- Component interfaces, defined as records polymorphic over the effect monad.+newtype Logger m = Logger+  { emitMsg :: String -> m ()+  }+  deriving stock (Generic)++data Repository m = Repository+  { insert :: Int -> m (),+    lookup :: Int -> m Bool+  }+  deriving stock (Generic)++newtype Controller m = Controller+  { -- insert one arg, look up the other. Nonsensical, but good enough for an example.+    route :: Int -> Int -> m Bool+  }+  deriving stock (Generic)++-- Component implementations, some of which depend on other components.+--+makeStdoutLogger :: MonadIO m => Logger m+makeStdoutLogger = Logger \msg -> liftIO $ putStrLn msg++-- allocation helper.+allocateSet :: Allocator (IORef (Set Int))+allocateSet = ContT $ bracket (newIORef Set.empty) pure++-- When a component depends on another, it does so by taking an "env" parameter+-- in the constructor and requiring 'Has' constraints on it.+makeInMemoryRepository ::+  (Has Logger m env, MonadIO m) =>+  IORef (Set Int) ->+  env ->+  Repository m+makeInMemoryRepository ref (asCall -> call) = do+  Repository+    { insert = \key -> do+        call emitMsg "inserting..."+        theSet <- liftIO $ readIORef ref+        liftIO $ writeIORef ref $ Set.insert key theSet,+      lookup = \key -> do+        call emitMsg "looking..."+        theSet <- liftIO $ readIORef ref+        pure (Set.member key theSet)+    }++-- This implementation of Controller depends both on the Logger and the+-- Repository.+--+-- In general, the graph of dependencies between components can be a complex+-- directed acyclic graph.+makeController ::+  (Has Logger m env, Has Repository m env, Monad m) =>+  env ->+  Controller m+makeController (asCall -> call) =+  Controller+    { route = \toInsert toLookup -> do+        call emitMsg "serving..."+        call insert toInsert+        call emitMsg "before lookup..."+        call lookup toLookup+    }++type MakeController2LoggersDeps = '[Logger, Tagged "secondary" Logger, Repository]+makeController2Loggers :: +  (HasAll MakeController2LoggersDeps 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.+--+-- We put all the components which will form part of our application in an+-- environment record.+--+-- Each field is wrapped in a functor `h` which controls the "phases" we must+-- go through in  the construction of the environment. When `h` becomes+-- Identity, the environment is ready for use. (This is an example of the+-- "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)+  }+  deriving stock (Generic)+  deriving anyclass (Phased, DemotableFieldNames, FieldsFindableByType)++-- Locate the components by their types. We could also define the required Has+-- instance for each component manually, but that's tedious.+deriving via Autowired (Env Identity m) instance Autowireable r_ m (Env Identity m) => Has r_ m (Env Identity m)++-- The "phases" that components go through until fully built. Each phase+-- is represented as an applicative functor. The succession of phases is+-- defined using Data.Functor.Compose.+--++-- A phase in which we might allocate some resource needed by the component,+-- also set some bracket-like resource management.+-- The "managed" library could be used instead of ContT.+type Allocator = ContT () IO++-- First we allocate any needed resource, then we have a construction phase+-- during which the component reads its own dependencies from a "completed"+-- environment.+--+-- There could be more phases, like for example an initial "read configuration"+-- phase.+type Phases env = Allocator `Compose` Constructor env++-- Environment value+--+-- The base monad is a 'ReaderT' holding a SyntheticCallStack value which gets modified+-- using "local" for each sub-call.+--+-- Notice that neither the interfaces nor the implementations which we defined+-- earlier knew anything about the ReaderT.+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+                ),+      logger2 =+        allocateBombs 0 `bindPhase` \bombs ->+          constructor \_ ->+            tagged @"secondary" makeStdoutLogger+              & advising+                ( adviseRecord @Top @Top \method ->+                    keepCallStack ioEx method <> injectFailures bombs+                ),+      repository =+        allocateSet `bindPhase` \ref ->+          constructor \env ->+            makeInMemoryRepository ref env+              & advising+                ( adviseRecord @Top @Top \method ->+                    keepCallStack ioEx method+                ),+      controller =+        skipPhase @Allocator $+          constructor \env ->+            makeController env+              & advising+                ( adviseRecord @Top @Top \method ->+                    keepCallStack ioEx method+                )+    }++-- Catch only IOExceptions for this example.+ioEx :: SomeException -> Maybe IOError+ioEx = fromException @IOError++-- Allocate a supply of potentially exception-throwing actions.+allocateBombs :: Int -> Allocator (IORef ([IO ()], [IO ()]))+allocateBombs whenToBomb = ContT $ bracket (newIORef bombs) pure+  where+    bombs =+      ( replicate whenToBomb (pure ()) ++ repeat (throwIO (userError "oops")),+        repeat (pure ())+      )++-- THE COMPOSITION ROOT - ALTERNATIVE APPROACH+--+--+-- Here we'll define the dependency injection environment in a slightly+-- different way (but reusing both the "business logic" and the Env type).++-- The basic idea is that we don't perform dependency injection as a separate+-- Applicative phase (so no Constructor, but a mere Identity phase).+--+-- Instead, we shift that task into the base monad's environent.++-- As a result the "phases" are simpler:+type Phases' = Allocator `Compose` Identity++-- Now the expanded "runtime" environment will hold both the synthetic call+-- stack and the components. We define this small helper datatype for that. It+-- augments a preexisting environment with call-related info.+data CallEnv i e_ m = CallEnv+  { _callInfo :: i,+    _ops :: e_ m+  }++-- Delegate all 'Has' queries to the inner environment.+instance Has r_ m (e_ m) => Has r_ m (CallEnv i e_ m) where+  dep = dep . _ops++instance HasSyntheticCallStack (CallEnv SyntheticCallStack e_ m) where+  callStack = lens _callInfo (\(CallEnv _ ops) i' -> CallEnv i' ops)++-- Here use the DepT monad (a variant of ReaderT) as the base monad.+--+-- 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+-- components.+env' :: Env Phases' (DepT (CallEnv SyntheticCallStack (Env Identity)) IO)+env' =+  Env+    { logger =+        allocateBombs 1 `bindPhase` \bombs ->+          Identity $ A.component \_ ->+            makeStdoutLogger+              & A.adviseRecord @Top @Top \method ->+                A.keepCallStack ioEx method <> A.injectFailures bombs,+      logger2 =+        allocateBombs 0 `bindPhase` \bombs ->+          Identity $ A.component \_ ->+            tagged @"secondary" makeStdoutLogger+              & A.adviseRecord @Top @Top \method ->+                A.keepCallStack ioEx method <> A.injectFailures bombs,+      repository =+        allocateSet `bindPhase` \ref ->+          Identity $ A.component \env ->+            makeInMemoryRepository ref env+              & A.adviseRecord @Top @Top \method ->+                A.keepCallStack ioEx method,+      controller =+        skipPhase @Allocator $+          Identity $ A.component \env ->+            makeController env+              & A.adviseRecord @Top @Top \method ->+                A.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 Constant, which makes DepT+-- behave almost as a regular ReaderT.+-- +-- 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 (Constant 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.keepCallStack ioEx method <> A.injectFailures bombs,+      logger2 =+        allocateBombs 0 `bindPhase` \bombs ->+           constructor \_ ->+            tagged @"secondary" makeStdoutLogger+              & A.adviseRecord @Top @Top \method ->+                A.keepCallStack ioEx method <> A.injectFailures bombs,+      repository =+        allocateSet `bindPhase` \ref ->+          constructor \env ->+            makeInMemoryRepository ref env+              & A.adviseRecord @Top @Top \method ->+                A.keepCallStack ioEx method,+      controller =+        skipPhase @Allocator $+          constructor \env ->+            makeController env+              & A.adviseRecord @Top @Top \method ->+                A.keepCallStack ioEx method+    }++-- TESTS+--+--+expectedException :: (IOError, SyntheticStackTrace)+expectedException =+  ( userError "oops",+    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+          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" 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+  let action =+        runContT (pullPhase @Allocator env') \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" 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.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 (Constant [])) (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.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 (Constant [])) (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 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 ()+main = defaultMain tests