dep-t 0.6.2.0 → 0.6.3.0
raw patch · 15 files changed
+3043/−3028 lines, 15 filesdep ~aesonsetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: aeson
API changes (from Hackage documentation)
+ Dep.Has: type DefaultFieldName r_ :: Symbol;
- Dep.Has: type family DefaultFieldName r_ :: Symbol;
+ Dep.Has: type family HasAll rs_ m e
Files
- CHANGELOG.md +100/−85
- LICENSE +30/−30
- README.md +359/−359
- Setup.hs +2/−2
- dep-t.cabal +106/−106
- lib/Control/Monad/Dep.hs +237/−237
- lib/Control/Monad/Dep/Class.hs +148/−148
- lib/Dep/Env.hs +723/−723
- lib/Dep/Has.hs +193/−193
- lib/Dep/Tagged.hs +90/−90
- test/doctests.hs +12/−12
- test/tests.hs +292/−292
- test/tests_curry.hs +139/−139
- test/tests_env.hs +230/−230
- test/tests_has.hs +382/−382
CHANGELOG.md view
@@ -1,85 +1,100 @@-# Revision history for dep-t - -## 0.6.2 - -* Moved `fromBare` and `toBare` from dep-t-dynamic. - -* Doc fix by @eyeinsky (PR #20) - -## 0.6.1.0 - -* Re-export `Data.Functor.Constant` from `Control.Monad.Dep`. https://github.com/danidiaz/dep-t/issues/18 - -## 0.6.0.0 - -* Added module `Dep.Tagged`. - -* Changed the `Constructor` type synonym. - - Now it takes a fully constructed environment type. - - This is a backwards-incompatible change. Type signatures might need to be modified, not so much term level code. - - https://github.com/danidiaz/dep-t/issues/17 - -* Removed deprecated modules. - -## 0.5.1.0 - -* `Control.Monad.Dep.Has` and `Control.Monad.Dep.Env` renamed as `Dep.Has` and `Dep.Env`. - - The old modules still remain, but deprecated. - -## 0.5.0.0 - -* `Phased` now has `Typeable` constraints. Should be a mostly backwards compatible - change, as `Typeable` instances are automagically generated for most types. - - Motivated by https://github.com/danidiaz/dep-t-dynamic/issues/1 - -## 0.4.6.0 - -* added new module Control.Monad.Dep.Env with helpers for defining environments of records. - -## 0.4.5.0 - -* added "asCall" to Control.Monad.Dep.Has - -## 0.4.4.0 - -* added Control.Monad.Dep.Has, a generic "Has" typeclass which favors a style in which - the components come wrapped in records or newtypes. - -* added "useEnv" to Control.Monad.Dep.Class. - -## 0.4.0.0 - -Actually no breaking changes here, but a change in the recommended structure of -the HasX helper classes, and in how to write general code against those -typeclasses. - -* added Control.Monad.Dep.Class - -## 0.1.3.0 - -* re-exported Control.Monad.Trans - -## 0.1.2.0 - -* re-exported Control.Monad.Reader.Class - -## 0.1.1.0 - -* Added NilEnv. - -## 0.1.0.2 - -* Minor documentation changes. - -## 0.1.0.1 - -* Minor documentation changes. - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. +# Revision history for dep-t++## 0.6.3++* Now the Bare typeclass doesn't recurse inside Identity or Const.++ Strictly speaking, this is a breaking change, but the cases in which it breaks+ are very unlikely in practice: when using Identity or Const in the *middle* of+ a sequence of phases. Typically, these two applicatives will be used as the+ colophon of the sequence of phases.+ + The motivation for the change is that letting Bare "peek" inside Identity and+ Const made it difficult to write fromBare-using functions polymorphic on the+ returned component. Bare got stuck on the component type variable and the+ functions did not compile. This led to unnecessary code duplication. Stopping+ at Identity means Bare never touches the type variable and doesn't get stuck.++## 0.6.2++* Moved `fromBare` and `toBare` from dep-t-dynamic.++* Doc fix by @eyeinsky (PR #20)++## 0.6.1.0++* Re-export `Data.Functor.Constant` from `Control.Monad.Dep`. https://github.com/danidiaz/dep-t/issues/18++## 0.6.0.0++* Added module `Dep.Tagged`.++* Changed the `Constructor` type synonym. ++ Now it takes a fully constructed environment type. ++ This is a backwards-incompatible change. Type signatures might need to be modified, not so much term level code.++ https://github.com/danidiaz/dep-t/issues/17++* Removed deprecated modules.++## 0.5.1.0++* `Control.Monad.Dep.Has` and `Control.Monad.Dep.Env` renamed as `Dep.Has` and `Dep.Env`.++ The old modules still remain, but deprecated.++## 0.5.0.0++* `Phased` now has `Typeable` constraints. Should be a mostly backwards compatible+ change, as `Typeable` instances are automagically generated for most types.++ Motivated by https://github.com/danidiaz/dep-t-dynamic/issues/1++## 0.4.6.0++* added new module Control.Monad.Dep.Env with helpers for defining environments of records.++## 0.4.5.0++* added "asCall" to Control.Monad.Dep.Has++## 0.4.4.0++* added Control.Monad.Dep.Has, a generic "Has" typeclass which favors a style in which+ the components come wrapped in records or newtypes.++* added "useEnv" to Control.Monad.Dep.Class.++## 0.4.0.0++Actually no breaking changes here, but a change in the recommended structure of+the HasX helper classes, and in how to write general code against those+typeclasses.++* added Control.Monad.Dep.Class++## 0.1.3.0++* re-exported Control.Monad.Trans++## 0.1.2.0++* re-exported Control.Monad.Reader.Class++## 0.1.1.0++* Added NilEnv.++## 0.1.0.2 ++* Minor documentation changes.++## 0.1.0.1 ++* Minor documentation changes.++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
LICENSE view
@@ -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.
README.md view
@@ -1,359 +1,359 @@-# dep-t - -This package provides various helpers for the "record-of-functions" style of structuring Haskell applications. The guiding idea is that record-of-functions is a form of dependency injection, and the that the environment which contains the functions is akin to an [`ApplicationContext`](https://docs.spring.io/spring-framework/docs/current/javadoc-api/org/springframework/context/ApplicationContext.html) in object-oriented frameworks like [Java Spring](https://docs.spring.io/spring-framework/docs/current/reference/html/). - -If every dependency knew about the concrete environment, that would increase coupling. The solution is to use `Has`-style classes so that each dependency knows only about those parts of the environment which it needs to function, and nothing more. Those `Has`-style classes can be tailor-made, but the package also provides a generic one. - -*Very* loosely speaking, `Has`-style constraints correspond to injected member variables in object-oriented frameworks. - -[](https://postimg.cc/V5bspcJB) - -- __Dep.Has__ contains a generic `Has` typeclass for locating dependencies in an environment. It can be useful independently of `ReaderT`, `DepT` or any monad transformer. -- __Dep.Env__ complements __Dep.Has__, adding helpers for building environments of records. -- __Dep.Tagged__ is a helper for disambiguating dependencies in __Dep.Env__ environments. -- __Control.Monad.Dep__ contains the `DepT` monad transformer, a variant of `ReaderT`. -- __Control.Monad.Dep.Class__ is an extension of `MonadReader`, useful to program against both `ReaderT` and `DepT`. - -## The DepT transformer - -`DepT` is a -[ReaderT](http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader.html)-like -monad transformer for dependency injection. - -The difference with `ReaderT` is that `DepT` takes an enviroment whose type is -parameterized by `DepT` itself. - -### Rationale - -To perform dependency injection in Haskell, a common solution is to build a -record of functions and pass it to the program logic using some variant of -[`ReaderT`](http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader.html). - -To avoid becoming tied to a concrete reader environment, let's define some -auxiliary typeclasses that extract functions from a generic environment: - - type HasLogger :: (Type -> Type) -> Type -> Constraint - class HasLogger d e | e -> d where - logger :: e -> String -> d () - - type HasRepository :: (Type -> Type) -> Type -> Constraint - class HasRepository d e | e -> d where - repository :: e -> Int -> d () - -We see that the type `e` of the environment determines the monad `d` on which -the effects take place. - -Here's a monomorphic environment record with functions that have effects in `IO`: - - type EnvIO :: Type - data EnvIO = EnvIO - { _loggerIO :: String -> IO (), - _repositoryIO :: Int -> IO () - } - - instance HasLogger IO EnvIO where - logger = _loggerIO - - instance HasRepository IO EnvIO where - repository = _repositoryIO - -[Record-of-functions-in-IO](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/) is a simple technique which works well in many -situations. There are even [specialized -libraries](http://hackage.haskell.org/package/rio) that support it. - -Here's a function which can get its dependencies from the monomorphic -environment: - - mkControllerIO :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String - mkControllerIO x = do - e <- ask - liftIO $ logger e "I'm going to insert in the db!" - liftIO $ repository e x - return "view" - -That's all and well, but there are two issues that bug me: - -- We might want to write code that is innocent of `IO` and polymorphic over the - monad, to ensure that the program logic can't do some unexpected missile - launch, or to allow testing our app in a "pure" way. - -- What if the repository function needs access to the logger, too? The - repository lives in the environment record, but isn't aware of it. That means - it can't use the `HasLogger` typeclass for easy and convenient dependency - injection. Why privilege the controller in such a way? - - In a sufficiently complex app, the diverse functions that comprise it will be - organized in a big - [DAG](https://en.wikipedia.org/wiki/Directed_acyclic_graph) of dependencies. - And it would be nice if all the functions taking part in dependency injection - were treated uniformly; if all of them had access to (some view of) the - environment record. - -To tackle these issues, we begin by giving the controller a more general signature: - - mkControllerIO :: (HasLogger IO e, HasRepository IO e, MonadIO m, MonadReader e m) => Int -> m String - -Now the function can work in other reader-like monads besides `ReaderT`. - -Let's go one step further, and abstract away the `IO`, so that functions in the -record can have effects in other monads: - - mkController :: (HasLogger d e, HasRepository d e, LiftDep d m, MonadReader e m) => Int -> m String - mkController x = do - e <- ask - liftD $ logger e "I'm going to insert in the db!" - liftD $ repository e x - return "view" - -Now both the signature and the implementation have changed: - -- There's a new type variable `d`, the monad in which functions taken from the - environment `e` have their effects. - -- `MonadIO` has been replaced by `LiftDep` from `Control.Monad.Dep.Class`, a - constraint that says we can lift `d` effects into `m` (though it could still - make sense to require `MonadIO m` for effects not originating in the - environment). - -- Uses of `liftIO` have been replaced by `liftD`. - -If all those constraints prove annoying to write, there's a convenient shorthand using the `MonadDep` type family: - - mkController :: MonadDep [HasLogger, HasRepository] d e m => Int -> m String - -The new, more polymorphic `mkController` function can replace the original `mkControllerIO`: - - mkControllerIO' :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String - mkControllerIO' = mkController - -Now let's focus on the environment record. We'll parameterize its type by a -monad: - - type Env :: (Type -> Type) -> Type - data Env m = Env - { _logger :: String -> m (), - _repository :: Int -> m (), - _controller :: Int -> m String - } - - instance HasLogger m (Env m) where - logger = _logger - - instance HasRepository m (Env m) where - repository = _repository - -Notice that the controller function is now part of the environment. No -favorites here! - -The following implementation of the logger function has no dependencies besides -`MonadIO`: - - mkStdoutLogger :: MonadIO m => String -> m () - mkStdoutLogger msg = liftIO (putStrLn msg) - -But look at this implementation of the repository function. It gets hold of the -logger through `HasLogger`, just as the controller did: - - mkStdoutRepository :: (MonadDep '[HasLogger] d e m, MonadIO m) => Int -> m () - mkStdoutRepository entity = do - e <- ask - liftD $ logger e "I'm going to write the entity!" - liftIO $ print entity - -It's about time we choose a concrete monad and assemble an environment record: - - envIO :: Env (DepT Env IO) - envIO = - let _logger = mkStdoutLogger - _repository = mkStdoutRepository - _controller = mkController - in Env {_logger, _repository, _controller} - -Not very complicated, except... what is that weird `DepT Env IO` doing there in -the signature? - -Well, that's the whole reason this library exists. For dependency injection to -work for *all* functions, `Env` needs to be parameterized with a monad that -provides that same `Env` environment. And trying to use a `ReaderT (Env -something) IO` to parameterize `Env` won't fly; you'll get weird "infinite -type" kind of errors. So I created the `DepT` newtype over `ReaderT` to mollify -the compiler. - -`DepT` has `MonadReader` and `LiftDep` instances, so the effects of -`mkController` can take place on it. - -### So how do we invoke the controller now? - -I suggest something like - - runDepT (do e <- ask; _controller e 7) envIO - -or - - (do e <- ask; _controller e 7) `runDepT` envIO - -The companion package -[dep-t-advice](http://hackage.haskell.org/package/dep-t-advice) has some more -functions for running `DepT` computations. - -### How to avoid using "ask" and "liftD" before invoking a dependency? - -One possible workaround (at the cost of more boilerplate) is to define helper -functions like: - - loggerD :: MonadDep '[HasLogger] d e m => String -> m () - loggerD msg = asks logger >>= \f -> liftD $ f msg - -Which you can invoke like this: - - usesLoggerD :: MonadDep [HasLogger, HasRepository] d e m => Int -> m String - usesLoggerD i = do - loggerD "I'm calling the logger!" - return "foo" - -Though perhaps this isn't worth the hassle. - -### How to use "pure fakes" during testing? - -The [test suite](./test/tests.hs) has an example of using a `Writer` monad for -collecting the outputs of functions working as ["test -doubles"](https://martinfowler.com/bliki/TestDouble.html). - -### How to make a function "see" a different evironment from the one seen by its dependencies? - -Sometimes we want a function in the environment to see a slightly different -record from the record seen by the other functions, and in particular from the -record seen by its own dependencies. - -For example, the function might have a `HasLogger` constraint but we don't want -it to use the default `HasLogger` instance of the environment. - -The companion package -[dep-t-advice](http://hackage.haskell.org/package/dep-t-advice) provides a -`deceive` function that allows for this. - -### How to add AOP-ish "aspects" to functions in an environment? - -The companion package -[dep-t-advice](http://hackage.haskell.org/package/dep-t-advice) provides a -general method of extending the behaviour of `DepT`-effectful functions, in a -way reminiscent of aspect-oriented programming. - -### What if I don't want to use DepT, or any other monad transformer for that matter? - -Check out the function `fixEnv` in module `Dep.Env`, which -provides a transformer-less way to perform dependency injection, based on -knot-tying. - -That method requires an environment parameterized by _two_ type constructors: -one that wraps each field, and another that works as the effect monad for the -components. - -### DepT caveats - -The structure of the `DepT` type might be prone to trigger a [known infelicity -of the GHC -simplifier](https://twitter.com/DiazCarrete/status/1350116413445439493). - -## Links - -- This library was extracted from my answer to [this Stack Overflow - question](https://stackoverflow.com/a/61782258/1364288). - -- The implementation of `mapDepT` was teased out in [this other SO question](https://stackoverflow.com/questions/65710657/writing-a-zooming-function-for-a-readert-like-monad-transformer). - -- An [SO - answer](https://stackoverflow.com/questions/57703898/how-to-call-impure-functions-from-pure-ones/57714058#57714058) - about records-of-functions and the "veil of polymorphism". - -- The answers to [this SO - question](https://stackoverflow.com/questions/61642492/simplifying-the-invocation-of-functions-stored-inside-an-readert-environment) - gave me the idea for how to "instrument" monadic functions (although the - original motive of the question was different). - -- I'm unsure of the relationship between `DepT` and the technique described in - [Adventures assembling records of - capabilities](https://discourse.haskell.org/t/adventures-assembling-records-of-capabilities/623) - which relies on having "open" and "closed" versions of the environment - record, and getting the latter from the former by means of knot-tying. - - It seems that, with `DepT`, functions in the environment obtain their - dependencies anew every time they are invoked. If we change a function in the - environment record, all other functions which depend on it will be affected - in subsequent invocations. I don't think this happens with "Adventures..." at - least when changing a "closed", already assembled record. - - With `DepT` a function might use `local` if it knows enough about the - environment. That doesn't seem very useful for program logic; if fact it - sounds like a recipe for confusion. But it enables [complex - scenarios](https://www.baeldung.com/spring-abstract-routing-data-source) for - which the dependency graph needs to change in the middle of a request. - - All in all, perhaps `DepT` will be overkill in a lot of cases, offering - unneeded flexibility. Perhaps using `fixEnv` from `Dep.Env` will end up being - simpler. - - Unlike in "Adventures..." the `fixEnv` method doesn't use an extensible - record for the environment but, to keep things simple, a suitably - parameterized conventional one. - -- Another exploration of dependency injection with `ReaderT`: - [ReaderT-OpenProduct-Environment](https://github.com/keksnicoh/ReaderT-OpenProduct-Environment). - -- [The ReaderT design pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/). - - > Your application code will, in general, live in ReaderT Env IO. Define it as type App = ReaderT Env IO if you wish, or use a newtype wrapper instead of ReaderT directly. - - > Optional: instead of directly using the App datatype, write your functions in terms of mtl-style typeclasses like MonadReader and MonadIO - -- [RIO](http://hackage.haskell.org/package/rio) is a featureful ReaderT-like / - prelude replacement library which favors monomorphic environments. - -- The [van Laarhoven Free Monad](http://r6.ca/blog/20140210T181244Z.html). - - > Swierstra notes that by summing together functors representing primitive I/O - > actions and taking the free monad of that sum, we can produce values use - > multiple I/O feature sets. Values defined on a subset of features can be - > lifted into the free monad generated by the sum. The equivalent process can - > be performed with the van Laarhoven free monad by taking the product of - > records of the primitive operations. Values defined on a subset of features - > can be lifted by composing the van Laarhoven free monad with suitable - > projection functions that pick out the requisite primitive operations. - - [Another post](https://www.tweag.io/blog/2019-03-20-capability-free-monad/van) about the van Laarhoven Free Monad. Is it related to the final encoding of Free monads described [here](https://blog.poisson.chat/posts/2021-10-20-initial-final-free-monad.html)? - -- [Interesting SO response](https://stackoverflow.com/a/634754/1364288) (from - 2009) about the benefits of autowiring in Spring. The record-of-functions - approach in Haskell can't be said to provide true autowiring. You still need - to assemble the record manually, and field names in the record play the part - of Spring bean names. - - > Right now I think the most important reason for using autowiring is that - > there's one less abstraction in your system to keep track of. The "bean name" - > is effectively gone. It turns out the bean name only exists because of xml. So - > a full layer of abstract indirections (where you would wire bean-name "foo" - > into bean "bar") is gone - -- [registry](http://hackage.haskell.org/package/registry) is a package that - implements an alternative approach to dependency injection, one different - from the `ReaderT`-based one. - -- [Printf("%s %s", dependency, injection)](https://www.fredrikholmqvist.com/posts/print-dependency-injection/). Commented on [HN](https://news.ycombinator.com/item?id=28915630), [Lobsters](https://lobste.rs/s/4axrt6/printf_s_s_dependency_injection). - -- [Dependency Injection Principles, Practices, and - Patterns](https://www.goodreads.com/book/show/44416307-dependency-injection-principles-practices-and-patterns) - This is a good book on the general princples of DI. - -- A [series of posts](https://twitter.com/ploeh/status/1485514524962738179)—by one of the authors of the DI book—about building a DI container. - -- [Lessons learned while writing a Haskell - application](https://gvolpe.com/blog/lessons-learned-while-writing-a-haskell-app/). - This post recommends a "polymorphic record of functions" style, which fits - the philosophy of this library. - -- One [big disadvantage](https://www.reddit.com/r/haskell/comments/r6foxv/opinions_on_reader_continuationbased_io/hmthsoy/) of the records-of-functions approach: - - > representing effects as records of functions rather than typeclasses/fused effect invocations destroys inlining, so you’ll generate significantly worse Core if you use this on a hot path. - -- [ReaderT pattern is just extensible effects](https://www.reddit.com/r/haskell/comments/sjhatp/readert_pattern_is_just_extensible_effects/) - +# dep-t++This package provides various helpers for the "record-of-functions" style of structuring Haskell applications. The guiding idea is that record-of-functions is a form of dependency injection, and the that the environment which contains the functions is akin to an [`ApplicationContext`](https://docs.spring.io/spring-framework/docs/current/javadoc-api/org/springframework/context/ApplicationContext.html) in object-oriented frameworks like [Java Spring](https://docs.spring.io/spring-framework/docs/current/reference/html/).++If every dependency knew about the concrete environment, that would increase coupling. The solution is to use `Has`-style classes so that each dependency knows only about those parts of the environment which it needs to function, and nothing more. Those `Has`-style classes can be tailor-made, but the package also provides a generic one. ++*Very* loosely speaking, `Has`-style constraints correspond to injected member variables in object-oriented frameworks.++[](https://postimg.cc/V5bspcJB)++- __Dep.Has__ contains a generic `Has` typeclass for locating dependencies in an environment. It can be useful independently of `ReaderT`, `DepT` or any monad transformer.+- __Dep.Env__ complements __Dep.Has__, adding helpers for building environments of records.+- __Dep.Tagged__ is a helper for disambiguating dependencies in __Dep.Env__ environments.+- __Control.Monad.Dep__ contains the `DepT` monad transformer, a variant of `ReaderT`.+- __Control.Monad.Dep.Class__ is an extension of `MonadReader`, useful to program against both `ReaderT` and `DepT`.++## The DepT transformer++`DepT` is a+[ReaderT](http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader.html)-like+monad transformer for dependency injection.++The difference with `ReaderT` is that `DepT` takes an enviroment whose type is+parameterized by `DepT` itself.++### Rationale++To perform dependency injection in Haskell, a common solution is to build a+record of functions and pass it to the program logic using some variant of+[`ReaderT`](http://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader.html).++To avoid becoming tied to a concrete reader environment, let's define some+auxiliary typeclasses that extract functions from a generic environment:++ type HasLogger :: (Type -> Type) -> Type -> Constraint+ class HasLogger d e | e -> d where+ logger :: e -> String -> d ()++ type HasRepository :: (Type -> Type) -> Type -> Constraint+ class HasRepository d e | e -> d where+ repository :: e -> Int -> d ()++We see that the type `e` of the environment determines the monad `d` on which+the effects take place.++Here's a monomorphic environment record with functions that have effects in `IO`:++ type EnvIO :: Type+ data EnvIO = EnvIO+ { _loggerIO :: String -> IO (),+ _repositoryIO :: Int -> IO ()+ }++ instance HasLogger IO EnvIO where+ logger = _loggerIO++ instance HasRepository IO EnvIO where+ repository = _repositoryIO++[Record-of-functions-in-IO](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/) is a simple technique which works well in many+situations. There are even [specialized+libraries](http://hackage.haskell.org/package/rio) that support it.++Here's a function which can get its dependencies from the monomorphic+environment:++ mkControllerIO :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String+ mkControllerIO x = do+ e <- ask+ liftIO $ logger e "I'm going to insert in the db!"+ liftIO $ repository e x+ return "view"++That's all and well, but there are two issues that bug me:++- We might want to write code that is innocent of `IO` and polymorphic over the+ monad, to ensure that the program logic can't do some unexpected missile+ launch, or to allow testing our app in a "pure" way. ++- What if the repository function needs access to the logger, too? The+ repository lives in the environment record, but isn't aware of it. That means+ it can't use the `HasLogger` typeclass for easy and convenient dependency+ injection. Why privilege the controller in such a way?++ In a sufficiently complex app, the diverse functions that comprise it will be+ organized in a big+ [DAG](https://en.wikipedia.org/wiki/Directed_acyclic_graph) of dependencies.+ And it would be nice if all the functions taking part in dependency injection+ were treated uniformly; if all of them had access to (some view of) the+ environment record.++To tackle these issues, we begin by giving the controller a more general signature:++ mkControllerIO :: (HasLogger IO e, HasRepository IO e, MonadIO m, MonadReader e m) => Int -> m String++Now the function can work in other reader-like monads besides `ReaderT`.++Let's go one step further, and abstract away the `IO`, so that functions in the+record can have effects in other monads:++ mkController :: (HasLogger d e, HasRepository d e, LiftDep d m, MonadReader e m) => Int -> m String+ mkController x = do+ e <- ask+ liftD $ logger e "I'm going to insert in the db!"+ liftD $ repository e x+ return "view"++Now both the signature and the implementation have changed:++- There's a new type variable `d`, the monad in which functions taken from the+ environment `e` have their effects.++- `MonadIO` has been replaced by `LiftDep` from `Control.Monad.Dep.Class`, a+ constraint that says we can lift `d` effects into `m` (though it could still+ make sense to require `MonadIO m` for effects not originating in the+ environment).++- Uses of `liftIO` have been replaced by `liftD`.++If all those constraints prove annoying to write, there's a convenient shorthand using the `MonadDep` type family:++ mkController :: MonadDep [HasLogger, HasRepository] d e m => Int -> m String++The new, more polymorphic `mkController` function can replace the original `mkControllerIO`:++ mkControllerIO' :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String+ mkControllerIO' = mkController++Now let's focus on the environment record. We'll parameterize its type by a+monad: ++ type Env :: (Type -> Type) -> Type+ data Env m = Env+ { _logger :: String -> m (),+ _repository :: Int -> m (),+ _controller :: Int -> m String+ }++ instance HasLogger m (Env m) where+ logger = _logger++ instance HasRepository m (Env m) where+ repository = _repository++Notice that the controller function is now part of the environment. No+favorites here!++The following implementation of the logger function has no dependencies besides+`MonadIO`:++ mkStdoutLogger :: MonadIO m => String -> m ()+ mkStdoutLogger msg = liftIO (putStrLn msg)++But look at this implementation of the repository function. It gets hold of the+logger through `HasLogger`, just as the controller did:++ mkStdoutRepository :: (MonadDep '[HasLogger] d e m, MonadIO m) => Int -> m ()+ mkStdoutRepository entity = do+ e <- ask+ liftD $ logger e "I'm going to write the entity!"+ liftIO $ print entity++It's about time we choose a concrete monad and assemble an environment record:++ envIO :: Env (DepT Env IO)+ envIO =+ let _logger = mkStdoutLogger+ _repository = mkStdoutRepository+ _controller = mkController+ in Env {_logger, _repository, _controller}++Not very complicated, except... what is that weird `DepT Env IO` doing there in+the signature? ++Well, that's the whole reason this library exists. For dependency injection to+work for *all* functions, `Env` needs to be parameterized with a monad that+provides that same `Env` environment. And trying to use a `ReaderT (Env+something) IO` to parameterize `Env` won't fly; you'll get weird "infinite+type" kind of errors. So I created the `DepT` newtype over `ReaderT` to mollify+the compiler.++`DepT` has `MonadReader` and `LiftDep` instances, so the effects of+`mkController` can take place on it.++### So how do we invoke the controller now?++I suggest something like++ runDepT (do e <- ask; _controller e 7) envIO ++or ++ (do e <- ask; _controller e 7) `runDepT` envIO ++The companion package+[dep-t-advice](http://hackage.haskell.org/package/dep-t-advice) has some more+functions for running `DepT` computations.++### How to avoid using "ask" and "liftD" before invoking a dependency?++One possible workaround (at the cost of more boilerplate) is to define helper+functions like: ++ loggerD :: MonadDep '[HasLogger] d e m => String -> m ()+ loggerD msg = asks logger >>= \f -> liftD $ f msg++Which you can invoke like this:++ usesLoggerD :: MonadDep [HasLogger, HasRepository] d e m => Int -> m String+ usesLoggerD i = do+ loggerD "I'm calling the logger!"+ return "foo"++Though perhaps this isn't worth the hassle.++### How to use "pure fakes" during testing?++The [test suite](./test/tests.hs) has an example of using a `Writer` monad for+collecting the outputs of functions working as ["test+doubles"](https://martinfowler.com/bliki/TestDouble.html).++### How to make a function "see" a different evironment from the one seen by its dependencies?++Sometimes we want a function in the environment to see a slightly different+record from the record seen by the other functions, and in particular from the+record seen by its own dependencies. ++For example, the function might have a `HasLogger` constraint but we don't want+it to use the default `HasLogger` instance of the environment.++The companion package+[dep-t-advice](http://hackage.haskell.org/package/dep-t-advice) provides a+`deceive` function that allows for this.++### How to add AOP-ish "aspects" to functions in an environment?++The companion package+[dep-t-advice](http://hackage.haskell.org/package/dep-t-advice) provides a+general method of extending the behaviour of `DepT`-effectful functions, in a+way reminiscent of aspect-oriented programming.++### What if I don't want to use DepT, or any other monad transformer for that matter?++Check out the function `fixEnv` in module `Dep.Env`, which+provides a transformer-less way to perform dependency injection, based on+knot-tying.++That method requires an environment parameterized by _two_ type constructors:+one that wraps each field, and another that works as the effect monad for the+components.++### DepT caveats++The structure of the `DepT` type might be prone to trigger a [known infelicity+of the GHC+simplifier](https://twitter.com/DiazCarrete/status/1350116413445439493).++## Links++- This library was extracted from my answer to [this Stack Overflow+ question](https://stackoverflow.com/a/61782258/1364288).++- The implementation of `mapDepT` was teased out in [this other SO question](https://stackoverflow.com/questions/65710657/writing-a-zooming-function-for-a-readert-like-monad-transformer).++- An [SO+ answer](https://stackoverflow.com/questions/57703898/how-to-call-impure-functions-from-pure-ones/57714058#57714058)+ about records-of-functions and the "veil of polymorphism".++- The answers to [this SO+ question](https://stackoverflow.com/questions/61642492/simplifying-the-invocation-of-functions-stored-inside-an-readert-environment)+ gave me the idea for how to "instrument" monadic functions (although the+ original motive of the question was different).++- I'm unsure of the relationship between `DepT` and the technique described in+ [Adventures assembling records of+ capabilities](https://discourse.haskell.org/t/adventures-assembling-records-of-capabilities/623)+ which relies on having "open" and "closed" versions of the environment+ record, and getting the latter from the former by means of knot-tying. ++ It seems that, with `DepT`, functions in the environment obtain their+ dependencies anew every time they are invoked. If we change a function in the+ environment record, all other functions which depend on it will be affected+ in subsequent invocations. I don't think this happens with "Adventures..." at+ least when changing a "closed", already assembled record.++ With `DepT` a function might use `local` if it knows enough about the+ environment. That doesn't seem very useful for program logic; if fact it+ sounds like a recipe for confusion. But it enables [complex+ scenarios](https://www.baeldung.com/spring-abstract-routing-data-source) for+ which the dependency graph needs to change in the middle of a request.++ All in all, perhaps `DepT` will be overkill in a lot of cases, offering+ unneeded flexibility. Perhaps using `fixEnv` from `Dep.Env` will end up being+ simpler.++ Unlike in "Adventures..." the `fixEnv` method doesn't use an extensible+ record for the environment but, to keep things simple, a suitably+ parameterized conventional one.++- Another exploration of dependency injection with `ReaderT`:+ [ReaderT-OpenProduct-Environment](https://github.com/keksnicoh/ReaderT-OpenProduct-Environment).++- [The ReaderT design pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/).++ > Your application code will, in general, live in ReaderT Env IO. Define it as type App = ReaderT Env IO if you wish, or use a newtype wrapper instead of ReaderT directly.++ > Optional: instead of directly using the App datatype, write your functions in terms of mtl-style typeclasses like MonadReader and MonadIO++- [RIO](http://hackage.haskell.org/package/rio) is a featureful ReaderT-like /+ prelude replacement library which favors monomorphic environments.++- The [van Laarhoven Free Monad](http://r6.ca/blog/20140210T181244Z.html).++ > Swierstra notes that by summing together functors representing primitive I/O+ > actions and taking the free monad of that sum, we can produce values use+ > multiple I/O feature sets. Values defined on a subset of features can be+ > lifted into the free monad generated by the sum. The equivalent process can+ > be performed with the van Laarhoven free monad by taking the product of+ > records of the primitive operations. Values defined on a subset of features+ > can be lifted by composing the van Laarhoven free monad with suitable+ > projection functions that pick out the requisite primitive operations. ++ [Another post](https://www.tweag.io/blog/2019-03-20-capability-free-monad/van) about the van Laarhoven Free Monad. Is it related to the final encoding of Free monads described [here](https://blog.poisson.chat/posts/2021-10-20-initial-final-free-monad.html)?++- [Interesting SO response](https://stackoverflow.com/a/634754/1364288) (from+ 2009) about the benefits of autowiring in Spring. The record-of-functions+ approach in Haskell can't be said to provide true autowiring. You still need+ to assemble the record manually, and field names in the record play the part+ of Spring bean names. ++ > Right now I think the most important reason for using autowiring is that+ > there's one less abstraction in your system to keep track of. The "bean name"+ > is effectively gone. It turns out the bean name only exists because of xml. So+ > a full layer of abstract indirections (where you would wire bean-name "foo"+ > into bean "bar") is gone++- [registry](http://hackage.haskell.org/package/registry) is a package that+ implements an alternative approach to dependency injection, one different+ from the `ReaderT`-based one. ++- [Printf("%s %s", dependency, injection)](https://www.fredrikholmqvist.com/posts/print-dependency-injection/). Commented on [HN](https://news.ycombinator.com/item?id=28915630), [Lobsters](https://lobste.rs/s/4axrt6/printf_s_s_dependency_injection).++- [Dependency Injection Principles, Practices, and+ Patterns](https://www.goodreads.com/book/show/44416307-dependency-injection-principles-practices-and-patterns)+ This is a good book on the general princples of DI. ++- A [series of posts](https://twitter.com/ploeh/status/1485514524962738179)—by one of the authors of the DI book—about building a DI container.++- [Lessons learned while writing a Haskell+ application](https://gvolpe.com/blog/lessons-learned-while-writing-a-haskell-app/).+ This post recommends a "polymorphic record of functions" style, which fits+ the philosophy of this library.++- One [big disadvantage](https://www.reddit.com/r/haskell/comments/r6foxv/opinions_on_reader_continuationbased_io/hmthsoy/) of the records-of-functions approach:++ > representing effects as records of functions rather than typeclasses/fused effect invocations destroys inlining, so you’ll generate significantly worse Core if you use this on a hot path.++- [ReaderT pattern is just extensible effects](https://www.reddit.com/r/haskell/comments/sjhatp/readert_pattern_is_just_extensible_effects/)+
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
dep-t.cabal view
@@ -1,106 +1,106 @@-cabal-version: 3.0 - -name: dep-t -version: 0.6.2.0 -synopsis: Dependency injection for records-of-functions. -description: Put all your functions in the environment record! Let all - your functions read from the environment record! No favorites! --- 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.git - -common common - build-depends: base >=4.10.0.0 && < 5, - transformers >= 0.5.0.0, - mtl >= 2.2, - unliftio-core >= 0.2.0.0, - default-language: Haskell2010 - -library - import: common - exposed-modules: Dep.Has - Dep.Env - Dep.Tagged - Control.Monad.Dep - Control.Monad.Dep.Class - hs-source-dirs: lib - -test-suite dep-t-test - import: common - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: tests.hs - build-depends: - dep-t, - rank2classes ^>= 1.4.1, - template-haskell, - tasty >= 1.3.1, - tasty-hunit >= 0.10.0.2, - -test-suite dep-t-test-curry - import: common - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: tests_curry.hs - build-depends: - dep-t, - rank2classes ^>= 1.4.1, - template-haskell, - tasty >= 1.3.1, - tasty-hunit >= 0.10.0.2, - sop-core ^>= 0.5.0.0, - -test-suite dep-t-test-has - import: common - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: tests_has.hs - build-depends: - dep-t, - rank2classes ^>= 1.4.1, - template-haskell, - tasty >= 1.3.1, - tasty-hunit >= 0.10.0.2, - sop-core ^>= 0.5.0.0, - barbies ^>= 2.0, - containers - -test-suite dep-t-test-env - import: common - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: tests_env.hs - build-depends: - dep-t, - rank2classes ^>= 1.4.1, - template-haskell, - tasty >= 1.3.1, - tasty-hunit >= 0.10.0.2, - sop-core ^>= 0.5.0.0, - aeson ^>= 2.0, - bytestring, - text, - containers - - --- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288 --- http://hackage.haskell.org/package/cabal-doctest -test-suite doctests - import: common - ghc-options: -threaded - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: doctests.hs - build-depends: - dep-t, - rank2classes ^>= 1.4.1, - doctest ^>= 0.20, - +cabal-version: 3.0++name: dep-t+version: 0.6.3.0+synopsis: Dependency injection for records-of-functions.+description: Put all your functions in the environment record! Let all+ your functions read from the environment record! No favorites!+-- 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.git++common common+ build-depends: base >=4.10.0.0 && < 5,+ transformers >= 0.5.0.0,+ mtl >= 2.2,+ unliftio-core >= 0.2.0.0,+ default-language: Haskell2010++library+ import: common+ exposed-modules: Dep.Has+ Dep.Env+ Dep.Tagged+ Control.Monad.Dep+ Control.Monad.Dep.Class+ hs-source-dirs: lib ++test-suite dep-t-test+ import: common+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: tests.hs+ build-depends: + dep-t, + rank2classes ^>= 1.4.1,+ template-haskell,+ tasty >= 1.3.1,+ tasty-hunit >= 0.10.0.2,++test-suite dep-t-test-curry+ import: common+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: tests_curry.hs+ build-depends: + dep-t, + rank2classes ^>= 1.4.1,+ template-haskell,+ tasty >= 1.3.1,+ tasty-hunit >= 0.10.0.2,+ sop-core ^>= 0.5.0.0,++test-suite dep-t-test-has+ import: common+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: tests_has.hs+ build-depends: + dep-t, + rank2classes ^>= 1.4.1,+ template-haskell,+ tasty >= 1.3.1,+ tasty-hunit >= 0.10.0.2,+ sop-core ^>= 0.5.0.0,+ barbies ^>= 2.0,+ containers++test-suite dep-t-test-env+ import: common+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: tests_env.hs+ build-depends: + dep-t, + rank2classes ^>= 1.4.1,+ template-haskell,+ tasty >= 1.3.1,+ tasty-hunit >= 0.10.0.2,+ sop-core ^>= 0.5.0.0,+ aeson >= 2.0,+ bytestring,+ text,+ containers+++-- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288+-- http://hackage.haskell.org/package/cabal-doctest+test-suite doctests+ import: common+ ghc-options: -threaded+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: doctests.hs+ build-depends: + dep-t, + rank2classes ^>= 1.4.1,+ doctest ^>= 0.20,+
lib/Control/Monad/Dep.hs view
@@ -1,238 +1,238 @@-{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE KindSignatures #-} - --- | --- This module provides 'DepT', a monad transformer similar to 'ReaderT'. --- --- The difference is that the environment of 'DepT' must be parameterized by --- @DepT@'s own monad stack. --- --- There's a function 'withDepT' which is analogous to 'withReaderT'. --- There's no analogue of 'mapReaderT' however. -module Control.Monad.Dep - ( - -- * The DepT transformer - DepT (DepT), - runDepT, - toReaderT, - withDepT, - zoomEnv, - -- * The simplest environment - NilEnv(NilEnv), - -- * The next simplest environment - -- $constant - Constant(..), - -- * Re-exports - module Control.Monad.Trans, - module Control.Monad.Dep.Class, - module Control.Monad.Reader.Class - ) -where - -import Control.Applicative -import Control.Monad.Trans -import Control.Monad.Cont.Class -import Control.Monad.Error.Class -import Control.Monad.IO.Unlift -import Control.Monad.Reader -import Control.Monad.Reader.Class -import Control.Monad.State.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Identity -import Control.Monad.Writer.Class -import Control.Monad.Zip -import Control.Monad.Dep.Class -import Data.Kind (Type) -import Data.Coerce -import Data.Functor.Constant - --- $setup --- --- >>> :set -XTypeApplications --- >>> :set -XImportQualifiedPost --- >>> :set -XTemplateHaskell --- >>> :set -XStandaloneKindSignatures --- >>> :set -XNamedFieldPuns --- >>> import Control.Monad.Dep --- >>> import Rank2 qualified --- >>> import Rank2.TH qualified --- - - --- | --- A monad transformer which adds a read-only environment to the given monad. --- The environment type must be parameterized with the transformer's stack. --- --- The 'return' function ignores the environment, while @>>=@ passes the --- inherited environment to both subcomputations. -type DepT :: - ((Type -> Type) -> Type) -> - (Type -> Type) -> - Type -> - Type -newtype DepT (e_ :: (Type -> Type) -> Type) (m :: Type -> Type) (r :: Type) = DepT {toReaderT :: ReaderT (e_ (DepT e_ m)) m r} - deriving - ( Functor, - Applicative, - Alternative, - Monad, - MonadFix, - MonadFail, - MonadZip, - MonadPlus, - MonadCont, - MonadIO, - MonadUnliftIO, - MonadReader (e_ (DepT e_ m)) - ) - -instance MonadTrans (DepT e_) where - lift = DepT . lift - -deriving instance MonadState s m => MonadState s (DepT e_ m) - -deriving instance MonadWriter w m => MonadWriter w (DepT e_ m) - -deriving instance MonadError e m => MonadError e (DepT e_ m) - --- | 'DepT' can be d-lifted to a 'ReaderT' in which the environment record --- containing further 'DepT' actions has been hidden behind a newtype. --- --- This can be useful to "deceive" a function into using an environment --- possessing different instances than the instances seen by the function's --- dependencies. -instance (Monad m, Coercible newtyped (e_ (DepT e_ m))) => LiftDep (DepT e_ m) (ReaderT newtyped m) where - liftD = coerce - - --- | 'DepT' can be d-lifted to itself. -instance Monad m => LiftDep (DepT e_ m) (DepT e_ m) where - liftD = id - --- | --- Runs a 'DepT' action in an environment. --- --- >>> runDepT (pure "foo") NilEnv --- "foo" --- --- For more sophisticated invocation functions, see @runFinalDepT@ and @runFromEnv@ from <http://hackage.haskell.org/package/dep-t-advice dep-t-advice>. -runDepT :: DepT e_ m r -> e_ (DepT e_ m) -> m r -runDepT = runReaderT . toReaderT - --- | --- Changes the environment of a 'DepT', for example making the 'DepT' work in --- a "bigger" environment than the one in which was defined initially. --- --- The scary first parameter is a function that, given a natural --- transformation of monads, changes the monad parameter of the environment --- record. This function can be defined manually for each environment record, --- or it can be generated using TH from the <http://hackage.haskell.org/package/rank2classes-1.4.1/docs/Rank2-TH.html#v:deriveFunctor rank2classes> package. -withDepT :: - forall small big m a. - Monad m => - -- | rank-2 map function - ( forall p q. - (forall x. p x -> q x) -> - small p -> - small q - ) -> - -- | get a small environment from a big one - (forall t. big t -> small t) -> - DepT small m a -> - DepT big m a -withDepT mapEnv inner (DepT (ReaderT f)) = - DepT - ( ReaderT - ( \big -> - let small :: small (DepT small m) - -- we have a big environment at hand, so let's extract the - -- small environment, transform every function in the small - -- environment by supplying the big environment and, as a - -- finishing touch, lift from the base monad m so that it - -- matches the monad expected by f. - small = mapEnv (lift . flip runDepT big) (inner big) - in f small - ) - ) - --- | --- Makes the functions inside a small environment require a bigger environment. --- --- The scary first parameter is a function that, given a natural --- transformation of monads, changes the monad parameter of the environment --- record. This function can be defined manually for each environment record, --- or it can be generated using TH from the <http://hackage.haskell.org/package/rank2classes-1.4.1/docs/Rank2-TH.html#v:deriveFunctor rank2classes> package. --- --- 'zoomEnv' can be useful if we are encasing some preexisting small environment as a field of --- a big environment, in order to make the types match: --- --- >>> :{ --- type Env :: (Type -> Type) -> Type --- data Env m = Env --- { _logger :: String -> m (), --- _repository :: Int -> m (), --- _controller :: Int -> m String --- } --- $(Rank2.TH.deriveFunctor ''Env) --- env :: Env (DepT Env IO) --- env = Env --- { _logger = \_ -> pure (), --- _repository = \_ -> pure (), --- _controller = \_ -> pure "foo" --- } --- type BiggerEnv :: (Type -> Type) -> Type --- data BiggerEnv m = BiggerEnv --- { _inner :: Env m, --- _extra :: Int -> m Int --- } --- biggerEnv :: BiggerEnv (DepT BiggerEnv IO) --- biggerEnv = BiggerEnv --- { _inner = zoomEnv (Rank2.<$>) _inner env, --- _extra = pure --- } --- :} --- --- __However__, this is only needed when the monad of the smaller environment --- is already \"fixed\" before inserting it in the bigger one—which I expect --- to be an infrequent case. When the concrete monad is selected after nesting --- the environments, 'zoomEnv' shouldn't be necessary. --- -{-# NOINLINE zoomEnv #-} --- For the reason for not inlining, see https://twitter.com/DiazCarrete/status/1350116413445439493 -zoomEnv :: - forall small big m a. - Monad m => - -- | rank-2 map function - ( forall p q. - (forall x. p x -> q x) -> - small p -> - small q - ) -> - -- | get a small environment from a big one - (forall t. big t -> small t) -> - small (DepT small m) -> - small (DepT big m) -zoomEnv mapEnv inner = mapEnv (withDepT mapEnv inner) - --- | An empty environment that carries no functions, analogous to `()` for `ReaderT`. -type NilEnv :: (Type -> Type) -> Type -data NilEnv m = NilEnv - - --- $constant --- --- 'Constant', which has a phantom type parameter, is a valid environment for --- 'DepT'. --- --- @DepT (Constant e) m@ makes 'DepT' behave similarly to @ReaderT e m@, --- in that the environment @e@ is independent of the monad. +{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE KindSignatures #-}++-- |+-- This module provides 'DepT', a monad transformer similar to 'ReaderT'.+--+-- The difference is that the environment of 'DepT' must be parameterized by+-- @DepT@'s own monad stack.+--+-- There's a function 'withDepT' which is analogous to 'withReaderT'.+-- There's no analogue of 'mapReaderT' however. +module Control.Monad.Dep+ ( + -- * The DepT transformer+ DepT (DepT),+ runDepT,+ toReaderT,+ withDepT,+ zoomEnv,+ -- * The simplest environment+ NilEnv(NilEnv),+ -- * The next simplest environment+ -- $constant+ Constant(..),+ -- * Re-exports+ module Control.Monad.Trans,+ module Control.Monad.Dep.Class,+ module Control.Monad.Reader.Class+ )+where++import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Cont.Class+import Control.Monad.Error.Class+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Control.Monad.Reader.Class+import Control.Monad.State.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Identity+import Control.Monad.Writer.Class+import Control.Monad.Zip+import Control.Monad.Dep.Class+import Data.Kind (Type)+import Data.Coerce+import Data.Functor.Constant++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XImportQualifiedPost+-- >>> :set -XTemplateHaskell+-- >>> :set -XStandaloneKindSignatures+-- >>> :set -XNamedFieldPuns+-- >>> import Control.Monad.Dep+-- >>> import Rank2 qualified+-- >>> import Rank2.TH qualified+--+++-- |+-- A monad transformer which adds a read-only environment to the given monad.+-- The environment type must be parameterized with the transformer's stack.+--+-- The 'return' function ignores the environment, while @>>=@ passes the+-- inherited environment to both subcomputations.+type DepT ::+ ((Type -> Type) -> Type) ->+ (Type -> Type) ->+ Type ->+ Type+newtype DepT (e_ :: (Type -> Type) -> Type) (m :: Type -> Type) (r :: Type) = DepT {toReaderT :: ReaderT (e_ (DepT e_ m)) m r}+ deriving+ ( Functor,+ Applicative,+ Alternative,+ Monad,+ MonadFix,+ MonadFail,+ MonadZip,+ MonadPlus,+ MonadCont,+ MonadIO,+ MonadUnliftIO,+ MonadReader (e_ (DepT e_ m))+ )++instance MonadTrans (DepT e_) where+ lift = DepT . lift++deriving instance MonadState s m => MonadState s (DepT e_ m)++deriving instance MonadWriter w m => MonadWriter w (DepT e_ m)++deriving instance MonadError e m => MonadError e (DepT e_ m)++-- | 'DepT' can be d-lifted to a 'ReaderT' in which the environment record+-- containing further 'DepT' actions has been hidden behind a newtype. +--+-- This can be useful to "deceive" a function into using an environment+-- possessing different instances than the instances seen by the function's+-- dependencies.+instance (Monad m, Coercible newtyped (e_ (DepT e_ m))) => LiftDep (DepT e_ m) (ReaderT newtyped m) where+ liftD = coerce+++-- | 'DepT' can be d-lifted to itself.+instance Monad m => LiftDep (DepT e_ m) (DepT e_ m) where+ liftD = id++-- |+-- Runs a 'DepT' action in an environment.+-- +-- >>> runDepT (pure "foo") NilEnv+-- "foo"+--+-- For more sophisticated invocation functions, see @runFinalDepT@ and @runFromEnv@ from <http://hackage.haskell.org/package/dep-t-advice dep-t-advice>.+runDepT :: DepT e_ m r -> e_ (DepT e_ m) -> m r+runDepT = runReaderT . toReaderT++-- |+-- Changes the environment of a 'DepT', for example making the 'DepT' work in+-- a "bigger" environment than the one in which was defined initially.+--+-- The scary first parameter is a function that, given a natural+-- transformation of monads, changes the monad parameter of the environment+-- record. This function can be defined manually for each environment record,+-- or it can be generated using TH from the <http://hackage.haskell.org/package/rank2classes-1.4.1/docs/Rank2-TH.html#v:deriveFunctor rank2classes> package.+withDepT ::+ forall small big m a.+ Monad m =>+ -- | rank-2 map function+ ( forall p q.+ (forall x. p x -> q x) ->+ small p ->+ small q+ ) ->+ -- | get a small environment from a big one+ (forall t. big t -> small t) ->+ DepT small m a ->+ DepT big m a+withDepT mapEnv inner (DepT (ReaderT f)) =+ DepT+ ( ReaderT+ ( \big ->+ let small :: small (DepT small m)+ -- we have a big environment at hand, so let's extract the+ -- small environment, transform every function in the small+ -- environment by supplying the big environment and, as a+ -- finishing touch, lift from the base monad m so that it+ -- matches the monad expected by f.+ small = mapEnv (lift . flip runDepT big) (inner big)+ in f small+ )+ )++-- |+-- Makes the functions inside a small environment require a bigger environment.+--+-- The scary first parameter is a function that, given a natural+-- transformation of monads, changes the monad parameter of the environment+-- record. This function can be defined manually for each environment record,+-- or it can be generated using TH from the <http://hackage.haskell.org/package/rank2classes-1.4.1/docs/Rank2-TH.html#v:deriveFunctor rank2classes> package.+--+-- 'zoomEnv' can be useful if we are encasing some preexisting small environment as a field of+-- a big environment, in order to make the types match:+--+-- >>> :{ +-- type Env :: (Type -> Type) -> Type+-- data Env m = Env+-- { _logger :: String -> m (),+-- _repository :: Int -> m (),+-- _controller :: Int -> m String+-- }+-- $(Rank2.TH.deriveFunctor ''Env)+-- env :: Env (DepT Env IO)+-- env = Env +-- { _logger = \_ -> pure (), +-- _repository = \_ -> pure (), +-- _controller = \_ -> pure "foo" +-- }+-- type BiggerEnv :: (Type -> Type) -> Type+-- data BiggerEnv m = BiggerEnv+-- { _inner :: Env m,+-- _extra :: Int -> m Int+-- }+-- biggerEnv :: BiggerEnv (DepT BiggerEnv IO)+-- biggerEnv = BiggerEnv +-- { _inner = zoomEnv (Rank2.<$>) _inner env, +-- _extra = pure+-- }+-- :}+--+-- __However__, this is only needed when the monad of the smaller environment+-- is already \"fixed\" before inserting it in the bigger one—which I expect+-- to be an infrequent case. When the concrete monad is selected after nesting+-- the environments, 'zoomEnv' shouldn't be necessary.+--+{-# NOINLINE zoomEnv #-}+-- For the reason for not inlining, see https://twitter.com/DiazCarrete/status/1350116413445439493+zoomEnv ::+ forall small big m a.+ Monad m =>+ -- | rank-2 map function+ ( forall p q.+ (forall x. p x -> q x) ->+ small p ->+ small q+ ) ->+ -- | get a small environment from a big one+ (forall t. big t -> small t) ->+ small (DepT small m) ->+ small (DepT big m)+zoomEnv mapEnv inner = mapEnv (withDepT mapEnv inner)++-- | An empty environment that carries no functions, analogous to `()` for `ReaderT`.+type NilEnv :: (Type -> Type) -> Type+data NilEnv m = NilEnv+++-- $constant+--+-- 'Constant', which has a phantom type parameter, is a valid environment for+-- 'DepT'.+-- +-- @DepT (Constant e) m@ makes 'DepT' behave similarly to @ReaderT e m@,+-- in that the environment @e@ is independent of the monad. --
lib/Control/Monad/Dep/Class.hs view
@@ -1,148 +1,148 @@-{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | This module provides definitions that let us translate record-of-functions code of the form: --- --- >>> :{ --- type HasLogger :: (Type -> Type) -> Type -> Constraint --- class HasLogger d e | e -> d where --- logger :: e -> String -> d () --- type HasRepository :: (Type -> Type) -> Type -> Constraint --- class HasRepository d e | e -> d where --- repository :: e -> Int -> d () --- mkControllerIO :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String --- mkControllerIO x = do --- e <- ask --- liftIO $ logger e "I'm going to insert in the db!" --- liftIO $ repository e x --- return "view" --- :} --- --- into the more polymorphic form: --- --- >>> :{ --- mkController :: MonadDep [HasLogger, HasRepository] d e m => Int -> m String --- mkController x = do --- e <- ask --- liftD $ logger e "I'm going to insert in the db!" --- liftD $ repository e x --- return "view" --- :} --- --- which can also be given the equivalent signature: --- --- >>> :{ --- mkController' :: (HasLogger d e, HasRepository d e, LiftDep d m, MonadReader e m) => Int -> m String --- mkController' = mkController --- :} --- --- The new code can be used as a drop-in replacement of the old one: --- --- >>> :{ --- mkControllerIO' :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String --- mkControllerIO' = mkController' --- :} --- --- Notice that in the new code effects taken from the environment record are --- lifted using 'liftD' instead of 'lift' or 'liftIO'. --- -module Control.Monad.Dep.Class - ( -- * Reader-like monads carrying dependencies in their environment - MonadDep, - - -- * Lifting effects from dependencies - LiftDep (..), - -- * Helpers - useEnv - ) -where - -import Control.Monad.Reader -import Data.Kind - --- $setup --- --- >>> :set -XTypeApplications --- >>> :set -XMultiParamTypeClasses --- >>> :set -XImportQualifiedPost --- >>> :set -XTemplateHaskell --- >>> :set -XStandaloneKindSignatures --- >>> :set -XNamedFieldPuns --- >>> :set -XFunctionalDependencies --- >>> :set -XFlexibleContexts --- >>> :set -XDataKinds --- >>> import Control.Monad.Reader --- >>> import Control.Monad.Dep --- >>> import Rank2 qualified --- >>> import Rank2.TH qualified --- - - --- | Auxiliary typeclass for monads that can be lifted to other monads. --- --- Its intended use is lifting monadic actions found in some reader-like --- environment. --- --- __Note:__ The @RIO@ monad from <http://hackage.haskell.org/package/rio rio> could be --- given a @LiftDept IO RIO@ instance; it's not done here to avoid increasing --- the dependency footprint. -type LiftDep :: (Type -> Type) -> (Type -> Type) -> Constraint -class Monad d => LiftDep d m where - liftD :: d x -> m x - --- | The simplest case: we can d-lift the base monad sitting just below a 'ReaderT'. --- --- (Perhaps this could be extended to any monad transformer, but let's leave it simple for now.) -instance Monad m => LiftDep m (ReaderT e m) where - liftD = lift - --- Trying to write a general "lift from anywhere in the stack" like --- instance (Monad m, LiftDep below m, MonadTrans t) => LiftDep below (t m) --- caused OverlappedInstances problems with DepT. --- Lot let's not try to be *excessively* general. - --- -- | Any monad can be \"lifted\" to itself. --- Better limit this to DepT --- instance LiftDep m m where --- liftD = id - --- | 'MonadDep' is not its own typeclass, but 'MonadReader' plus some supplementary constraints. --- --- A @MonadDep dependencies d e m@ is a @MonadReader e m@ where the environment --- @e@ provides some @dependencies@ with effects in the monad @d@, additionally requiring that the --- effects can be lifted back to the monad @m@ by using 'liftD'. --- --- The @dependencies@ are specified as a type-level list of two-parameter --- @HasX@ typeclasses. Those typeclasses should expect the effect monad --- @d@ as its first parameter. --- --- Writing code polymorphic over 'MonadDep' lets us execute it in both 'ReaderT' and 'Control.Monad.Dep.DepT' contexts. -type MonadDep :: - [(Type -> Type) -> Type -> Constraint] -> - (Type -> Type) -> - Type -> - (Type -> Type) -> - Constraint -type family MonadDep (dependencies :: [(Type -> Type) -> Type -> Constraint]) (d :: Type -> Type) (e :: Type) (m :: Type -> Type) where - MonadDep '[] d e m = (LiftDep d m, MonadReader e m) - MonadDep (dependency ': dependencies) d e m = (dependency d e, MonadDep dependencies d e m) - --- | Avoids repeated calls to 'liftD' when all the effects in a function come from the environment. -useEnv :: forall d e m r. (LiftDep d m, MonadReader e m) => (e -> d r) -> m r -useEnv f = do - e <- ask - liftD (f e) - +{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module provides definitions that let us translate record-of-functions code of the form:+--+-- >>> :{ +-- type HasLogger :: (Type -> Type) -> Type -> Constraint+-- class HasLogger d e | e -> d where+-- logger :: e -> String -> d ()+-- type HasRepository :: (Type -> Type) -> Type -> Constraint+-- class HasRepository d e | e -> d where+-- repository :: e -> Int -> d ()+-- mkControllerIO :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String+-- mkControllerIO x = do+-- e <- ask+-- liftIO $ logger e "I'm going to insert in the db!"+-- liftIO $ repository e x+-- return "view"+-- :}+--+-- into the more polymorphic form:+--+-- >>> :{+-- mkController :: MonadDep [HasLogger, HasRepository] d e m => Int -> m String+-- mkController x = do+-- e <- ask+-- liftD $ logger e "I'm going to insert in the db!"+-- liftD $ repository e x+-- return "view"+-- :}+--+-- which can also be given the equivalent signature:+--+-- >>> :{+-- mkController' :: (HasLogger d e, HasRepository d e, LiftDep d m, MonadReader e m) => Int -> m String+-- mkController' = mkController+-- :} +--+-- The new code can be used as a drop-in replacement of the old one: +--+-- >>> :{ +-- mkControllerIO' :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String+-- mkControllerIO' = mkController'+-- :}+--+-- Notice that in the new code effects taken from the environment record are+-- lifted using 'liftD' instead of 'lift' or 'liftIO'. +--+module Control.Monad.Dep.Class+ ( -- * Reader-like monads carrying dependencies in their environment+ MonadDep,++ -- * Lifting effects from dependencies+ LiftDep (..),+ -- * Helpers+ useEnv+ )+where++import Control.Monad.Reader+import Data.Kind++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XImportQualifiedPost+-- >>> :set -XTemplateHaskell+-- >>> :set -XStandaloneKindSignatures+-- >>> :set -XNamedFieldPuns+-- >>> :set -XFunctionalDependencies+-- >>> :set -XFlexibleContexts+-- >>> :set -XDataKinds+-- >>> import Control.Monad.Reader+-- >>> import Control.Monad.Dep+-- >>> import Rank2 qualified+-- >>> import Rank2.TH qualified+--+++-- | Auxiliary typeclass for monads that can be lifted to other monads.+--+-- Its intended use is lifting monadic actions found in some reader-like+-- environment.+--+-- __Note:__ The @RIO@ monad from <http://hackage.haskell.org/package/rio rio> could be+-- given a @LiftDept IO RIO@ instance; it's not done here to avoid increasing+-- the dependency footprint.+type LiftDep :: (Type -> Type) -> (Type -> Type) -> Constraint+class Monad d => LiftDep d m where+ liftD :: d x -> m x++-- | The simplest case: we can d-lift the base monad sitting just below a 'ReaderT'.+--+-- (Perhaps this could be extended to any monad transformer, but let's leave it simple for now.)+instance Monad m => LiftDep m (ReaderT e m) where+ liftD = lift++-- Trying to write a general "lift from anywhere in the stack" like+-- instance (Monad m, LiftDep below m, MonadTrans t) => LiftDep below (t m)+-- caused OverlappedInstances problems with DepT.+-- Lot let's not try to be *excessively* general.++-- -- | Any monad can be \"lifted\" to itself.+-- Better limit this to DepT+-- instance LiftDep m m where+-- liftD = id++-- | 'MonadDep' is not its own typeclass, but 'MonadReader' plus some supplementary constraints. +--+-- A @MonadDep dependencies d e m@ is a @MonadReader e m@ where the environment+-- @e@ provides some @dependencies@ with effects in the monad @d@, additionally requiring that the +-- effects can be lifted back to the monad @m@ by using 'liftD'.+--+-- The @dependencies@ are specified as a type-level list of two-parameter+-- @HasX@ typeclasses. Those typeclasses should expect the effect monad+-- @d@ as its first parameter.+--+-- Writing code polymorphic over 'MonadDep' lets us execute it in both 'ReaderT' and 'Control.Monad.Dep.DepT' contexts.+type MonadDep ::+ [(Type -> Type) -> Type -> Constraint] ->+ (Type -> Type) ->+ Type ->+ (Type -> Type) ->+ Constraint+type family MonadDep (dependencies :: [(Type -> Type) -> Type -> Constraint]) (d :: Type -> Type) (e :: Type) (m :: Type -> Type) where+ MonadDep '[] d e m = (LiftDep d m, MonadReader e m)+ MonadDep (dependency ': dependencies) d e m = (dependency d e, MonadDep dependencies d e m)++-- | Avoids repeated calls to 'liftD' when all the effects in a function come from the environment.+useEnv :: forall d e m r. (LiftDep d m, MonadReader e m) => (e -> d r) -> m r+useEnv f = do+ e <- ask+ liftD (f e)+
lib/Dep/Env.hs view
@@ -1,723 +1,723 @@-{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE GADTs #-} - --- | This module provides helpers for building dependency injection --- environments composed of records. --- --- It's not necessary when defining the record components themselves, in that --- case "Dep.Has" should suffice. --- --- >>> :{ --- type Logger :: (Type -> Type) -> Type --- newtype Logger d = Logger { --- info :: String -> d () --- } --- -- --- data Repository d = Repository --- { findById :: Int -> d (Maybe String) --- , putById :: Int -> String -> d () --- , insert :: String -> d Int --- } --- -- --- data Controller d = Controller --- { create :: d Int --- , append :: Int -> String -> d Bool --- , inspect :: Int -> d (Maybe String) --- } --- -- --- type EnvHKD :: (Type -> Type) -> (Type -> Type) -> Type --- data EnvHKD h m = EnvHKD --- { logger :: h (Logger m), --- repository :: h (Repository m), --- controller :: h (Controller m) --- } deriving stock Generic --- deriving anyclass (FieldsFindableByType, DemotableFieldNames, Phased) --- deriving via Autowired (EnvHKD Identity m) instance Autowireable r_ m (EnvHKD Identity m) => Has r_ m (EnvHKD Identity m) --- :} --- --- --- The module also provides a monad transformer-less way of performing dependency --- injection, by means of 'fixEnv'. --- -module Dep.Env ( - -- * A general-purpose Has - Has - -- * Helpers for deriving Has - -- ** via the default field name - , TheDefaultFieldName (..) - -- ** via arbitrary field name - , TheFieldName (..) - -- ** via autowiring - , FieldsFindableByType (..) - , Autowired (..) - , Autowireable - -- * Managing phases - , Phased (..) - , pullPhase - , mapPhase - , liftA2Phase - -- ** Working with field names - , DemotableFieldNames (..) - , demoteFieldNames - , mapPhaseWithFieldNames - -- ** Constructing phases - -- $phasehelpers - , bindPhase - , skipPhase - -- $phasehelpers2 - , Bare - , fromBare - , toBare - -- * Injecting dependencies by tying the knot - , fixEnv - , Constructor - , constructor - -- * Inductive environment with anonymous fields - , InductiveEnv (..) - , addDep - , emptyEnv - -- * Re-exports - , Identity (..) - , Constant (..) - , Compose (..) - ) where - -import Dep.Has -import Data.Kind -import GHC.Records -import GHC.TypeLits -import Data.Coerce -import GHC.Generics qualified as G -import Control.Applicative -import Data.Proxy -import Data.Functor ((<&>), ($>)) -import Data.Functor.Compose -import Data.Functor.Constant -import Data.Functor.Identity -import Data.Function (fix) -import Data.String -import Data.Type.Equality (type (==)) -import Data.Typeable - --- $setup --- --- >>> :set -XTypeApplications --- >>> :set -XMultiParamTypeClasses --- >>> :set -XImportQualifiedPost --- >>> :set -XTemplateHaskell --- >>> :set -XStandaloneKindSignatures --- >>> :set -XNamedFieldPuns --- >>> :set -XFunctionalDependencies --- >>> :set -XFlexibleContexts --- >>> :set -XDataKinds --- >>> :set -XBlockArguments --- >>> :set -XFlexibleInstances --- >>> :set -XTypeFamilies --- >>> :set -XDeriveGeneric --- >>> :set -XViewPatterns --- >>> :set -XDerivingStrategies --- >>> :set -XDerivingVia --- >>> :set -XDeriveAnyClass --- >>> :set -XStandaloneDeriving --- >>> :set -XUndecidableInstances --- >>> :set -XTypeOperators --- >>> :set -XScopedTypeVariables --- >>> import Data.Kind --- >>> import Data.Function ((&)) --- >>> import Control.Monad.IO.Class --- >>> import Dep.Env --- >>> import Dep.Env --- >>> import GHC.Generics (Generic) --- - - --- via the default field name - --- | Helper for @DerivingVia@ 'HasField' instances. --- --- It expects the component to have as field name the default fieldname --- specified by 'Dep'. --- --- This is the same behavior as the @DefaultSignatures@ implementation for --- 'Has', so maybe it doesn't make much sense to use it, except for --- explicitness. -newtype TheDefaultFieldName (env :: Type) = TheDefaultFieldName env - -instance (Dep r_, HasField (DefaultFieldName r_) (env_ m) u, Coercible u (r_ m)) - => Has r_ m (TheDefaultFieldName (env_ m)) where - dep (TheDefaultFieldName env) = coerce . getField @(DefaultFieldName r_) $ env - --- | Helper for @DerivingVia@ 'HasField' instances. --- --- The field name is specified as a 'Symbol'. -type TheFieldName :: Symbol -> Type -> Type -newtype TheFieldName (name :: Symbol) (env :: Type) = TheFieldName env - -instance (HasField name (env_ m) u, Coercible u (r_ m)) - => Has r_ m (TheFieldName name (env_ m)) where - dep (TheFieldName env) = coerce . getField @name $ env - --- via autowiring - --- | Class for getting the field name from the field's type. --- --- The default implementation of 'FindFieldByType' requires a 'G.Generic' --- instance, but users can write their own implementations. -type FieldsFindableByType :: Type -> Constraint -class FieldsFindableByType (env :: Type) where - type FindFieldByType env (r :: Type) :: Symbol - type FindFieldByType env r = FindFieldByType_ env r - --- | Helper for @DerivingVia@ 'HasField' instances. --- --- The fields are identified by their types. --- --- It uses 'FindFieldByType' under the hood. --- --- __BEWARE__: for large records with many components, this technique might --- incur in long compilation times. -type Autowired :: Type -> Type -newtype Autowired (env :: Type) = Autowired env - --- | Constraints required when @DerivingVia@ /all/ possible instances of 'Has' in --- a single definition. --- --- This only works for environments where all the fields come wrapped in --- "Data.Functor.Identity". -type Autowireable r_ (m :: Type -> Type) (env :: Type) = HasField (FindFieldByType env (r_ m)) env (Identity (r_ m)) - -instance ( - FieldsFindableByType (env_ m), - HasField (FindFieldByType (env_ m) (r_ m)) (env_ m) u, - Coercible u (r_ m) - ) - => Has r_ m (Autowired (env_ m)) where - dep (Autowired env) = coerce @u $ getField @(FindFieldByType (env_ m) (r_ m)) env - -type FindFieldByType_ :: Type -> Type -> Symbol -type family FindFieldByType_ env r where - FindFieldByType_ env r = IfMissing r (GFindFieldByType (ExtractProduct (G.Rep env)) r) - -type ExtractProduct :: (k -> Type) -> k -> Type -type family ExtractProduct envRep where - ExtractProduct (G.D1 _ (G.C1 _ z)) = z - -type IfMissing :: Type -> Maybe Symbol -> Symbol -type family IfMissing r ms where - IfMissing r Nothing = - TypeError ( - Text "The component " - :<>: ShowType r - :<>: Text " could not be found in environment.") - IfMissing _ (Just name) = name - --- The k -> Type alwasy trips me up -type GFindFieldByType :: (k -> Type) -> Type -> Maybe Symbol -type family GFindFieldByType r x where - GFindFieldByType (left G.:*: right) r = - WithLeftResult_ (GFindFieldByType left r) right r - GFindFieldByType (G.S1 (G.MetaSel ('Just name) _ _ _) (G.Rec0 r)) r = Just name - -- Here we are saying "any wrapper whatsoever over r". Too general? - -- If the wrapper is not coercible to the underlying r, we'll fail later. - GFindFieldByType (G.S1 (G.MetaSel ('Just name) _ _ _) (G.Rec0 (_ r))) r = Just name - GFindFieldByType _ _ = Nothing - -type WithLeftResult_ :: Maybe Symbol -> (k -> Type) -> Type -> Maybe Symbol -type family WithLeftResult_ leftResult right r where - WithLeftResult_ ('Just ls) right r = 'Just ls - WithLeftResult_ Nothing right r = GFindFieldByType right r - --- --- --- Managing Phases - --- see also https://github.com/haskell/cabal/issues/7394#issuecomment-861767980 - --- | Class of 2-parameter environments for which the first parameter @h@ wraps --- each field and corresponds to phases in the construction of the environment, --- and the second parameter @m@ is the effect monad used by each component. --- --- @h@ will typically be a composition of applicative functors, each one --- representing a phase. We advance through the phases by \"pulling out\" the --- outermost phase and running it in some way, until we are are left with a --- 'Constructor' phase, which we can remove using 'fixEnv'. --- --- 'Phased' resembles [FunctorT, TraversableT and ApplicativeT](https://hackage.haskell.org/package/barbies-2.0.3.0/docs/Data-Functor-Transformer.html) from the [barbies](https://hackage.haskell.org/package/barbies) library. 'Phased' instances can be written in terms of them. -type Phased :: ((Type -> Type) -> (Type -> Type) -> Type) -> Constraint -class Phased (env_ :: (Type -> Type) -> (Type -> Type) -> Type) where - -- | Used to implement 'pullPhase' and 'mapPhase', typically you should use those functions instead. - traverseH - :: forall (h :: Type -> Type) - (f :: Type -> Type) - (g :: Type -> Type) - (m :: Type -> Type). - ( Applicative f - , Typeable f - , Typeable g - , Typeable h - , Typeable m - ) => - -- | - (forall x . h x -> f (g x)) -> - -- | - env_ h m -> - -- | - f (env_ g m) - default traverseH - :: forall (h :: Type -> Type) - (f :: Type -> Type) - (g :: Type -> Type) - (m :: Type -> Type). - ( Applicative f - , Typeable f - , Typeable g - , Typeable h - , Typeable m - , G.Generic (env_ h m) - , G.Generic (env_ g m) - , GTraverseH h g (G.Rep (env_ h m)) (G.Rep (env_ g m)) - ) - => (forall x . h x -> f (g x)) -> env_ h m -> f (env_ g m) - traverseH t env = G.to <$> gTraverseH t (G.from env) - -- | Used to implement 'liftA2Phase', typically you should use that function instead. - liftA2H - :: forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) (m :: Type -> Type) . - ( Typeable a - , Typeable f - , Typeable f' - , Typeable m - ) - => - (forall x. a x -> f x -> f' x) -> - -- | - env_ a m -> - -- | - env_ f m -> - -- | - env_ f' m - default liftA2H - :: forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) m . - ( Typeable a - , Typeable f - , Typeable f' - , Typeable m - , G.Generic (env_ a m) - , G.Generic (env_ f m) - , G.Generic (env_ f' m) - , GLiftA2Phase a f f' (G.Rep (env_ a m)) (G.Rep (env_ f m)) (G.Rep (env_ f' m)) - ) - => (forall x. a x -> f x -> f' x) -> env_ a m -> env_ f m -> env_ f' m - liftA2H f enva env = G.to (gLiftA2Phase f (G.from enva) (G.from env)) - --- | Take the outermost phase wrapping each component and \"pull it outwards\", --- aggregating the phase's applicative effects. --- --- >>> :{ --- newtype Foo d = Foo {foo :: String -> d ()} deriving Generic --- makeIOFoo :: MonadIO m => Foo m --- makeIOFoo = Foo (liftIO . putStrLn) --- env :: InductiveEnv '[Foo] (IO `Compose` Constructor (InductiveEnv '[Foo] Identity IO)) IO --- env = EmptyEnv --- & AddDep @Foo (putStrLn "io phase" `bindPhase` \() -> constructor (\_ -> makeIOFoo)) --- ioOutside :: IO (InductiveEnv '[Foo] (Constructor (InductiveEnv '[Foo] Identity IO)) IO) --- ioOutside = pullPhase env --- :} --- -pullPhase :: forall (f :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . (Phased env_, Applicative f, Typeable f, Typeable g, Typeable m) - => - -- | - env_ (Compose f g) m - -> - -- | - f (env_ g m) --- f first to help annotate the phase -pullPhase = traverseH @env_ getCompose - --- | Modify the outermost phase wrapping each component. --- --- >>> :{ --- newtype Foo d = Foo {foo :: String -> d ()} deriving Generic --- makeIOFoo :: MonadIO m => Foo m --- makeIOFoo = Foo (liftIO . putStrLn) --- env :: InductiveEnv '[Foo] ((,) Int `Compose` Constructor String) IO --- env = EmptyEnv --- & AddDep @Foo ((2,()) `bindPhase` \() -> constructor (\_ -> makeIOFoo)) --- env' :: InductiveEnv '[Foo] ((,) String `Compose` Constructor String) IO --- env' = mapPhase (\(n,x) -> (show n,x)) env --- :} --- --- -mapPhase :: forall (f :: Type -> Type) (f' :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . (Phased env_ , Typeable f, Typeable f', Typeable g, Typeable m) - => - -- | - (forall x. f x -> f' x) - -> - -- | - env_ (Compose f g) m - -> - -- | - env_ (Compose f' g) m --- f' first to help annotate the *target* of the transform? -mapPhase f env = runIdentity $ traverseH @env_ (\(Compose fg) -> Identity (Compose (f fg))) env - --- | Combine two environments with a function that works on their outermost phases. -liftA2Phase - :: forall (a :: Type -> Type) (f' :: Type -> Type) (f :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . (Phased env_, Typeable a, Typeable f, Typeable f', Typeable g, Typeable m) - => - -- | - (forall x. a x -> f x -> f' x) - -> - -- | - env_ (Compose a g) m - -> - -- | - env_ (Compose f g) m - -> - -- | - env_ (Compose f' g) m --- f' first to help annotate the *target* of the transform? -liftA2Phase f = liftA2H @env_ (\(Compose fa) (Compose fg) -> Compose (f fa fg)) - -class GTraverseH h g env env' | env -> h, env' -> g where - gTraverseH :: Applicative f => (forall x . h x -> f (g x)) -> env x -> f (env' x) - -instance (GTraverseH h g fields fields') - => GTraverseH h - g - (G.D1 metaData (G.C1 metaCons fields)) - (G.D1 metaData (G.C1 metaCons fields')) where - gTraverseH t (G.M1 (G.M1 fields)) = - G.M1 . G.M1 <$> gTraverseH @h @g t fields - -instance (GTraverseH h g left left', - GTraverseH h g right right') - => GTraverseH h g (left G.:*: right) (left' G.:*: right') where - gTraverseH t (left G.:*: right) = - let left' = gTraverseH @h @g t left - right' = gTraverseH @h @g t right - in liftA2 (G.:*:) left' right' - -instance GTraverseH h g (G.S1 metaSel (G.Rec0 (h bean))) - (G.S1 metaSel (G.Rec0 (g bean))) where - gTraverseH t (G.M1 (G.K1 (hbean))) = - G.M1 . G.K1 <$> t hbean --- --- -class GLiftA2Phase a f f' enva env env' | enva -> a, env -> f, env' -> f' where - gLiftA2Phase :: (forall r. a r -> f r -> f' r) -> enva x -> env x -> env' x - -instance GLiftA2Phase a f f' fieldsa fields fields' - => GLiftA2Phase - a - f - f' - (G.D1 metaData (G.C1 metaCons fieldsa)) - (G.D1 metaData (G.C1 metaCons fields)) - (G.D1 metaData (G.C1 metaCons fields')) where - gLiftA2Phase f (G.M1 (G.M1 fieldsa)) (G.M1 (G.M1 fields)) = - G.M1 (G.M1 (gLiftA2Phase @a @f @f' f fieldsa fields)) - -instance ( GLiftA2Phase a f f' lefta left left', - GLiftA2Phase a f f' righta right right' - ) - => GLiftA2Phase a f f' (lefta G.:*: righta) (left G.:*: right) (left' G.:*: right') where - gLiftA2Phase f (lefta G.:*: righta) (left G.:*: right) = - let left' = gLiftA2Phase @a @f @f' f lefta left - right' = gLiftA2Phase @a @f @f' f righta right - in (G.:*:) left' right' - -instance GLiftA2Phase a f f' (G.S1 metaSel (G.Rec0 (a bean))) - (G.S1 metaSel (G.Rec0 (f bean))) - (G.S1 metaSel (G.Rec0 (f' bean))) where - gLiftA2Phase f (G.M1 (G.K1 abean)) (G.M1 (G.K1 fgbean)) = - G.M1 (G.K1 (f abean fgbean)) - --- | Class of 2-parameter environments for which it's possible to obtain the --- names of each field as values. -type DemotableFieldNames :: ((Type -> Type) -> (Type -> Type) -> Type) -> Constraint -class DemotableFieldNames env_ where - demoteFieldNamesH :: (forall x. String -> h String x) -> env_ (h String) m - default demoteFieldNamesH - :: ( G.Generic (env_ (h String) m) - , GDemotableFieldNamesH h (G.Rep (env_ (h String) m))) - => (forall x. String -> h String x) - -> env_ (h String) m - demoteFieldNamesH f = G.to (gDemoteFieldNamesH f) - --- | Bring down the field names of the environment to the term level and store --- them in the accumulator of "Data.Functor.Constant". -demoteFieldNames :: forall env_ m . DemotableFieldNames env_ => env_ (Constant String) m -demoteFieldNames = demoteFieldNamesH Constant - -class GDemotableFieldNamesH h env | env -> h where - gDemoteFieldNamesH :: (forall x. String -> h String x) -> env x - -instance GDemotableFieldNamesH h fields - => GDemotableFieldNamesH h (G.D1 metaData (G.C1 metaCons fields)) where - gDemoteFieldNamesH f = G.M1 (G.M1 (gDemoteFieldNamesH f)) - -instance ( GDemotableFieldNamesH h left, - GDemotableFieldNamesH h right) - => GDemotableFieldNamesH h (left G.:*: right) where - gDemoteFieldNamesH f = - gDemoteFieldNamesH f G.:*: gDemoteFieldNamesH f - -instance KnownSymbol name => GDemotableFieldNamesH h (G.S1 (G.MetaSel ('Just name) u v w) (G.Rec0 (h String bean))) where - gDemoteFieldNamesH f = - G.M1 (G.K1 (f (symbolVal (Proxy @name)))) - --- | Modify the outermost phase wrapping each component, while having access to --- the field name of the component. --- --- A typical usage is modifying a \"parsing the configuration\" phase so that --- each component looks into a different section of the global configuration --- field. -mapPhaseWithFieldNames :: - forall (f :: Type -> Type) (f' :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . - ( Phased env_ - , DemotableFieldNames env_ - , Typeable f - , Typeable f' - , Typeable g - , Typeable m ) - => - -- | - (forall x. String -> f x -> f' x) - -> - -- | - env_ (Compose f g) m - -> - -- | - env_ (Compose f' g) m --- f' first to help annotate the *target* of the transform? -mapPhaseWithFieldNames f env = - liftA2Phase (\(Constant name) z -> f name z) (runIdentity $ traverseH @env_ (\(Constant z) -> Identity (Compose (Constant z))) demoteFieldNames) env - - --- constructing phases - --- $phasehelpers --- --- 'bindPhase' and 'skipPhase' are small convenience functions to help build nested compositions of functors. --- - --- $phasehelpers2 --- --- 'fromBare' and 'toBare' are an alternative method to build nested compositions of functors, which relies on "coerce". --- - - --- | Use the result of the previous phase to build the next one. --- --- Can be useful infix. --- --- >>> :{ --- type Phases = IO `Compose` IO `Compose` Identity --- phased :: Phases Int --- phased = --- pure 1 `bindPhase` \i1 -> --- pure 2 `bindPhase` \i2 -> --- Identity (i1 + i2) --- :} --- --- -bindPhase :: forall f g a b . Functor f => f a -> (a -> g b) -> Compose f g b --- f as first type parameter to help annotate the current phase -bindPhase f k = Compose (f <&> k) - --- | Don't do anything for the current phase, just wrap the next one. --- --- >>> :{ --- type Phases = IO `Compose` IO `Compose` Identity --- phased :: Phases Int --- phased = --- skipPhase $ --- skipPhase $ --- Identity 1 --- :} --- -skipPhase :: forall f g a . Applicative f => g a -> Compose f g a --- f as first type parameter to help annotate the current phase -skipPhase g = Compose (pure g) - --- | This type family clears newtypes like 'Compose', 'Identity' and 'Constant' from a composite type, --- leaving you with a newtypeless nested type as result. --- --- The idea is that it might be easier to construct values of the \"bare\" version of a composite type, --- and later coerce them to the newtyped version using 'fromBare'. --- --- This is mainly intended for defining the nested 'Applicative' \"phases\" of components that live in a 'Phased' --- environment. It's an alternative to functions like `Dep.Env.bindPhase' and 'Dep.Env.skipPhase'. -type Bare :: Type -> Type -type family Bare x where - Bare (Compose outer inner x) = Bare (outer (Bare (inner x))) - Bare (Identity x) = Bare x - Bare (Const x k) = Bare x - Bare (Constant x k) = Bare x - Bare other = other - --- | Convert a value from its bare version to the newtyped one, usually as a step --- towards inserting it into a 'Phased' environment. --- --- >>> :{ --- type Phases = IO `Compose` IO `Compose` IO --- wrapped :: Phases Int = fromBare $ pure $ pure $ pure 3 --- :} --- --- >>> :{ --- type Phases = Constructor Int --- wrapped :: Phases Int --- wrapped = fromBare $ succ --- :} --- --- >>> :{ --- type Phases = IO `Compose` Constructor Int --- wrapped :: Phases Int --- wrapped = fromBare $ pure $ succ --- :} --- -fromBare :: Coercible phases (Bare phases) => Bare phases -> phases -fromBare = coerce - --- | Convert from the newtyped value to the bare one. 'fromBare' tends to be more useful. -toBare :: Coercible phases (Bare phases) => phases -> Bare phases -toBare = coerce - - --- | A phase with the effect of \"constructing each component by reading its --- dependencies from a completed environment\". --- --- The 'Constructor' phase for an environment will typically be parameterized --- with the environment itself. -type Constructor (env :: Type) = ((->) env) `Compose` Identity - - --- | Turn an environment-consuming function into a 'Constructor' that can be slotted --- into some field of a 'Phased' environment. -constructor :: forall r_ m env . (env -> r_ m) -> Constructor env (r_ m) --- same order of type parameters as Has -constructor = coerce - --- | This is a method of performing dependency injection that doesn't require --- "Control.Monad.Dep.DepT" at all. In fact, it doesn't require the use of --- /any/ monad transformer! --- --- If we have a environment whose fields are functions that construct each --- component by searching for its dependencies in a \"fully built\" version of --- the environment, we can \"tie the knot\" to obtain the \"fully built\" --- environment. This works as long as there aren't any circular dependencies --- between components. --- --- Think of it as a version of 'Data.Function.fix' that, instead of \"tying\" a single --- function, ties a whole record of them. --- --- The @env_ (Constructor (env_ Identity m)) m@ parameter might be the result of peeling --- away successive layers of applicative functor composition using 'pullPhase', --- until only the wiring phase remains. --- --- >>> :{ --- newtype Foo d = Foo {foo :: String -> d ()} deriving Generic --- newtype Bar d = Bar {bar :: String -> d ()} deriving Generic --- makeIOFoo :: MonadIO m => Foo m --- makeIOFoo = Foo (liftIO . putStrLn) --- makeBar :: Has Foo m env => env -> Bar m --- makeBar (asCall -> call) = Bar (call foo) --- env :: InductiveEnv [Bar,Foo] (Constructor (InductiveEnv [Bar,Foo] Identity IO)) IO --- env = EmptyEnv --- & AddDep @Foo (constructor (\_ -> makeIOFoo)) --- & AddDep @Bar (constructor makeBar) --- envReady :: InductiveEnv [Bar,Foo] Identity IO --- envReady = fixEnv env --- :} --- --- >>> :{ --- bar (dep envReady) "this is bar" --- :} --- this is bar --- -fixEnv :: (Phased env_, Typeable env_, Typeable m) => - -- | Environment where each field is wrapped in a 'Constructor' - env_ (Constructor (env_ Identity m)) m -> - -- | Fully constructed environment, ready for use. - env_ Identity m -fixEnv env = fix (pullPhase env) - --- | An inductively constructed environment with anonymous fields. --- --- Can be useful for simple tests. Also for converting `Has`-based --- components into functions that take their dependencies as separate --- positional parameters. --- --- > makeController :: (Monad m, Has Logger m env, Has Repository m env) => env -> Controller m --- > makeController = undefined --- > makeControllerPositional :: Monad m => Logger m -> Repository m -> Controller m --- > makeControllerPositional a b = makeController $ addDep @Logger a $ addDep @Repository b $ emptyEnv --- > makeController' :: (Monad m, Has Logger m env, Has Repository m env) => env -> Controller m --- > makeController' env = makeControllerPositional (dep env) (dep env) --- --- -data InductiveEnv (rs :: [(Type -> Type) -> Type]) (h :: Type -> Type) (m :: Type -> Type) where - AddDep :: forall r_ m rs h . h (r_ m) -> InductiveEnv rs h m -> InductiveEnv (r_ : rs) h m - EmptyEnv :: forall m h . InductiveEnv '[] h m - --- | Unlike the 'AddDep' constructor, this sets @h@ to 'Identity'. -addDep :: forall r_ m rs . r_ m -> InductiveEnv rs Identity m -> InductiveEnv (r_ : rs) Identity m -addDep = AddDep @r_ @m @rs . Identity - --- | Unlike the 'EmptyEnv' constructor, this sets @h@ to 'Identity'. -emptyEnv :: forall m . InductiveEnv '[] Identity m -emptyEnv = EmptyEnv @m @Identity - -instance Phased (InductiveEnv rs) where - traverseH t EmptyEnv = pure EmptyEnv - traverseH t (AddDep hx rest) = - let headF = t hx - restF = traverseH t rest - in AddDep <$> headF <*> restF - liftA2H t EmptyEnv EmptyEnv = EmptyEnv - liftA2H t (AddDep ax arest) (AddDep hx hrest) = - AddDep (t ax hx) (liftA2H t arest hrest) - --- | Works by searching on the list of types. -instance InductiveEnvFind r_ m rs => Has r_ m (InductiveEnv rs Identity m) where - dep = inductiveEnvDep - -class InductiveEnvFind r_ m rs where - inductiveEnvDep :: InductiveEnv rs Identity m -> r_ m - -instance TypeError ( - Text "The component " - :<>: ShowType r_ - :<>: Text " could not be found in environment.") => InductiveEnvFind r_ m '[] where - inductiveEnvDep = error "never happens" - -instance InductiveEnvFind' (r_ == r_') r_ m (r_' : rs) => InductiveEnvFind r_ m (r_' : rs) where - inductiveEnvDep = inductiveEnvDep' @(r_ == r_') - -class InductiveEnvFind' (matches :: Bool) r_ m rs where - inductiveEnvDep' :: InductiveEnv rs Identity m -> r_ m - -instance InductiveEnvFind' True r_ m (r_ : rs) where - inductiveEnvDep' (AddDep (Identity r) _) = r - -instance InductiveEnvFind r_ m rs => InductiveEnvFind' False r_ m (x : rs) where - inductiveEnvDep' (AddDep _ rest) = inductiveEnvDep rest - - +{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}++-- | This module provides helpers for building dependency injection+-- environments composed of records.+--+-- It's not necessary when defining the record components themselves, in that+-- case "Dep.Has" should suffice.+--+-- >>> :{+-- type Logger :: (Type -> Type) -> Type+-- newtype Logger d = Logger {+-- info :: String -> d ()+-- }+-- --+-- data Repository d = Repository+-- { findById :: Int -> d (Maybe String)+-- , putById :: Int -> String -> d ()+-- , insert :: String -> d Int+-- }+-- --+-- data Controller d = Controller +-- { create :: d Int+-- , append :: Int -> String -> d Bool +-- , inspect :: Int -> d (Maybe String)+-- } +-- --+-- type EnvHKD :: (Type -> Type) -> (Type -> Type) -> Type+-- data EnvHKD h m = EnvHKD+-- { logger :: h (Logger m),+-- repository :: h (Repository m),+-- controller :: h (Controller m)+-- } deriving stock Generic+-- deriving anyclass (FieldsFindableByType, DemotableFieldNames, Phased)+-- deriving via Autowired (EnvHKD Identity m) instance Autowireable r_ m (EnvHKD Identity m) => Has r_ m (EnvHKD Identity m)+-- :}+--+--+-- The module also provides a monad transformer-less way of performing dependency+-- injection, by means of 'fixEnv'.+--+module Dep.Env (+ -- * A general-purpose Has+ Has+ -- * Helpers for deriving Has+ -- ** via the default field name+ , TheDefaultFieldName (..)+ -- ** via arbitrary field name+ , TheFieldName (..)+ -- ** via autowiring+ , FieldsFindableByType (..)+ , Autowired (..)+ , Autowireable+ -- * Managing phases+ , Phased (..)+ , pullPhase+ , mapPhase+ , liftA2Phase+ -- ** Working with field names+ , DemotableFieldNames (..)+ , demoteFieldNames+ , mapPhaseWithFieldNames+ -- ** Constructing phases+ -- $phasehelpers+ , bindPhase+ , skipPhase + -- $phasehelpers2+ , Bare+ , fromBare+ , toBare+ -- * Injecting dependencies by tying the knot+ , fixEnv+ , Constructor+ , constructor+ -- * Inductive environment with anonymous fields+ , InductiveEnv (..)+ , addDep+ , emptyEnv+ -- * Re-exports+ , Identity (..)+ , Constant (..)+ , Compose (..)+ ) where++import Dep.Has +import Data.Kind+import GHC.Records+import GHC.TypeLits+import Data.Coerce+import GHC.Generics qualified as G+import Control.Applicative+import Data.Proxy+import Data.Functor ((<&>), ($>))+import Data.Functor.Compose+import Data.Functor.Constant+import Data.Functor.Identity+import Data.Function (fix)+import Data.String+import Data.Type.Equality (type (==))+import Data.Typeable++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XImportQualifiedPost+-- >>> :set -XTemplateHaskell+-- >>> :set -XStandaloneKindSignatures+-- >>> :set -XNamedFieldPuns+-- >>> :set -XFunctionalDependencies+-- >>> :set -XFlexibleContexts+-- >>> :set -XDataKinds+-- >>> :set -XBlockArguments+-- >>> :set -XFlexibleInstances+-- >>> :set -XTypeFamilies+-- >>> :set -XDeriveGeneric+-- >>> :set -XViewPatterns+-- >>> :set -XDerivingStrategies+-- >>> :set -XDerivingVia+-- >>> :set -XDeriveAnyClass+-- >>> :set -XStandaloneDeriving+-- >>> :set -XUndecidableInstances+-- >>> :set -XTypeOperators+-- >>> :set -XScopedTypeVariables+-- >>> import Data.Kind+-- >>> import Data.Function ((&))+-- >>> import Control.Monad.IO.Class+-- >>> import Dep.Env+-- >>> import Dep.Env+-- >>> import GHC.Generics (Generic)+--+++-- via the default field name++-- | Helper for @DerivingVia@ 'HasField' instances.+--+-- It expects the component to have as field name the default fieldname+-- specified by 'Dep'.+--+-- This is the same behavior as the @DefaultSignatures@ implementation for+-- 'Has', so maybe it doesn't make much sense to use it, except for+-- explicitness.+newtype TheDefaultFieldName (env :: Type) = TheDefaultFieldName env++instance (Dep r_, HasField (DefaultFieldName r_) (env_ m) u, Coercible u (r_ m)) + => Has r_ m (TheDefaultFieldName (env_ m)) where+ dep (TheDefaultFieldName env) = coerce . getField @(DefaultFieldName r_) $ env++-- | Helper for @DerivingVia@ 'HasField' instances.+--+-- The field name is specified as a 'Symbol'.+type TheFieldName :: Symbol -> Type -> Type+newtype TheFieldName (name :: Symbol) (env :: Type) = TheFieldName env++instance (HasField name (env_ m) u, Coercible u (r_ m)) + => Has r_ m (TheFieldName name (env_ m)) where+ dep (TheFieldName env) = coerce . getField @name $ env++-- via autowiring++-- | Class for getting the field name from the field's type.+--+-- The default implementation of 'FindFieldByType' requires a 'G.Generic'+-- instance, but users can write their own implementations.+type FieldsFindableByType :: Type -> Constraint+class FieldsFindableByType (env :: Type) where+ type FindFieldByType env (r :: Type) :: Symbol + type FindFieldByType env r = FindFieldByType_ env r++-- | Helper for @DerivingVia@ 'HasField' instances.+--+-- The fields are identified by their types.+--+-- It uses 'FindFieldByType' under the hood.+--+-- __BEWARE__: for large records with many components, this technique might+-- incur in long compilation times.+type Autowired :: Type -> Type+newtype Autowired (env :: Type) = Autowired env++-- | Constraints required when @DerivingVia@ /all/ possible instances of 'Has' in+-- a single definition.+--+-- This only works for environments where all the fields come wrapped in+-- "Data.Functor.Identity".+type Autowireable r_ (m :: Type -> Type) (env :: Type) = HasField (FindFieldByType env (r_ m)) env (Identity (r_ m))++instance (+ FieldsFindableByType (env_ m),+ HasField (FindFieldByType (env_ m) (r_ m)) (env_ m) u,+ Coercible u (r_ m) + ) + => Has r_ m (Autowired (env_ m)) where+ dep (Autowired env) = coerce @u $ getField @(FindFieldByType (env_ m) (r_ m)) env++type FindFieldByType_ :: Type -> Type -> Symbol+type family FindFieldByType_ env r where+ FindFieldByType_ env r = IfMissing r (GFindFieldByType (ExtractProduct (G.Rep env)) r)++type ExtractProduct :: (k -> Type) -> k -> Type+type family ExtractProduct envRep where+ ExtractProduct (G.D1 _ (G.C1 _ z)) = z++type IfMissing :: Type -> Maybe Symbol -> Symbol+type family IfMissing r ms where+ IfMissing r Nothing = + TypeError (+ Text "The component " + :<>: ShowType r + :<>: Text " could not be found in environment.")+ IfMissing _ (Just name) = name++-- The k -> Type alwasy trips me up+type GFindFieldByType :: (k -> Type) -> Type -> Maybe Symbol+type family GFindFieldByType r x where+ GFindFieldByType (left G.:*: right) r = + WithLeftResult_ (GFindFieldByType left r) right r+ GFindFieldByType (G.S1 (G.MetaSel ('Just name) _ _ _) (G.Rec0 r)) r = Just name+ -- Here we are saying "any wrapper whatsoever over r". Too general?+ -- If the wrapper is not coercible to the underlying r, we'll fail later.+ GFindFieldByType (G.S1 (G.MetaSel ('Just name) _ _ _) (G.Rec0 (_ r))) r = Just name+ GFindFieldByType _ _ = Nothing++type WithLeftResult_ :: Maybe Symbol -> (k -> Type) -> Type -> Maybe Symbol +type family WithLeftResult_ leftResult right r where+ WithLeftResult_ ('Just ls) right r = 'Just ls+ WithLeftResult_ Nothing right r = GFindFieldByType right r++--+--+-- Managing Phases++-- see also https://github.com/haskell/cabal/issues/7394#issuecomment-861767980++-- | Class of 2-parameter environments for which the first parameter @h@ wraps+-- each field and corresponds to phases in the construction of the environment,+-- and the second parameter @m@ is the effect monad used by each component.+--+-- @h@ will typically be a composition of applicative functors, each one+-- representing a phase. We advance through the phases by \"pulling out\" the+-- outermost phase and running it in some way, until we are are left with a+-- 'Constructor' phase, which we can remove using 'fixEnv'.+--+-- 'Phased' resembles [FunctorT, TraversableT and ApplicativeT](https://hackage.haskell.org/package/barbies-2.0.3.0/docs/Data-Functor-Transformer.html) from the [barbies](https://hackage.haskell.org/package/barbies) library. 'Phased' instances can be written in terms of them.+type Phased :: ((Type -> Type) -> (Type -> Type) -> Type) -> Constraint+class Phased (env_ :: (Type -> Type) -> (Type -> Type) -> Type) where+ -- | Used to implement 'pullPhase' and 'mapPhase', typically you should use those functions instead.+ traverseH + :: forall (h :: Type -> Type) + (f :: Type -> Type) + (g :: Type -> Type) + (m :: Type -> Type). + ( Applicative f + , Typeable f+ , Typeable g+ , Typeable h+ , Typeable m+ ) => + -- |+ (forall x . h x -> f (g x)) ->+ -- |+ env_ h m ->+ -- |+ f (env_ g m)+ default traverseH + :: forall (h :: Type -> Type) + (f :: Type -> Type) + (g :: Type -> Type) + (m :: Type -> Type). + ( Applicative f + , Typeable f+ , Typeable g+ , Typeable h+ , Typeable m+ , G.Generic (env_ h m)+ , G.Generic (env_ g m)+ , GTraverseH h g (G.Rep (env_ h m)) (G.Rep (env_ g m))+ )+ => (forall x . h x -> f (g x)) -> env_ h m -> f (env_ g m)+ traverseH t env = G.to <$> gTraverseH t (G.from env)+ -- | Used to implement 'liftA2Phase', typically you should use that function instead.+ liftA2H+ :: forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) (m :: Type -> Type) .+ ( Typeable a+ , Typeable f+ , Typeable f'+ , Typeable m+ )+ => + (forall x. a x -> f x -> f' x) -> + -- |+ env_ a m -> + -- |+ env_ f m -> + -- |+ env_ f' m+ default liftA2H+ :: forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) m .+ ( Typeable a+ , Typeable f+ , Typeable f'+ , Typeable m+ , G.Generic (env_ a m)+ , G.Generic (env_ f m)+ , G.Generic (env_ f' m)+ , GLiftA2Phase a f f' (G.Rep (env_ a m)) (G.Rep (env_ f m)) (G.Rep (env_ f' m))+ )+ => (forall x. a x -> f x -> f' x) -> env_ a m -> env_ f m -> env_ f' m+ liftA2H f enva env = G.to (gLiftA2Phase f (G.from enva) (G.from env))++-- | Take the outermost phase wrapping each component and \"pull it outwards\",+-- aggregating the phase's applicative effects.+--+-- >>> :{+-- newtype Foo d = Foo {foo :: String -> d ()} deriving Generic+-- makeIOFoo :: MonadIO m => Foo m+-- makeIOFoo = Foo (liftIO . putStrLn)+-- env :: InductiveEnv '[Foo] (IO `Compose` Constructor (InductiveEnv '[Foo] Identity IO)) IO+-- env = EmptyEnv +-- & AddDep @Foo (putStrLn "io phase" `bindPhase` \() -> constructor (\_ -> makeIOFoo))+-- ioOutside :: IO (InductiveEnv '[Foo] (Constructor (InductiveEnv '[Foo] Identity IO)) IO)+-- ioOutside = pullPhase env+-- :}+--+pullPhase :: forall (f :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . (Phased env_, Applicative f, Typeable f, Typeable g, Typeable m) + => + -- |+ env_ (Compose f g) m + -> + -- |+ f (env_ g m)+-- f first to help annotate the phase+pullPhase = traverseH @env_ getCompose++-- | Modify the outermost phase wrapping each component.+--+-- >>> :{+-- newtype Foo d = Foo {foo :: String -> d ()} deriving Generic+-- makeIOFoo :: MonadIO m => Foo m+-- makeIOFoo = Foo (liftIO . putStrLn)+-- env :: InductiveEnv '[Foo] ((,) Int `Compose` Constructor String) IO+-- env = EmptyEnv +-- & AddDep @Foo ((2,()) `bindPhase` \() -> constructor (\_ -> makeIOFoo))+-- env' :: InductiveEnv '[Foo] ((,) String `Compose` Constructor String) IO+-- env' = mapPhase (\(n,x) -> (show n,x)) env+-- :}+--+--+mapPhase :: forall (f :: Type -> Type) (f' :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . (Phased env_ , Typeable f, Typeable f', Typeable g, Typeable m) + => + -- |+ (forall x. f x -> f' x) + -> + -- |+ env_ (Compose f g) m + -> + -- |+ env_ (Compose f' g) m+-- f' first to help annotate the *target* of the transform?+mapPhase f env = runIdentity $ traverseH @env_ (\(Compose fg) -> Identity (Compose (f fg))) env++-- | Combine two environments with a function that works on their outermost phases.+liftA2Phase + :: forall (a :: Type -> Type) (f' :: Type -> Type) (f :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . (Phased env_, Typeable a, Typeable f, Typeable f', Typeable g, Typeable m) + => + -- |+ (forall x. a x -> f x -> f' x) + -> + -- |+ env_ (Compose a g) m + -> + -- |+ env_ (Compose f g) m + -> + -- |+ env_ (Compose f' g) m+-- f' first to help annotate the *target* of the transform?+liftA2Phase f = liftA2H @env_ (\(Compose fa) (Compose fg) -> Compose (f fa fg))++class GTraverseH h g env env' | env -> h, env' -> g where+ gTraverseH :: Applicative f => (forall x . h x -> f (g x)) -> env x -> f (env' x)++instance (GTraverseH h g fields fields')+ => GTraverseH h + g+ (G.D1 metaData (G.C1 metaCons fields)) + (G.D1 metaData (G.C1 metaCons fields')) where+ gTraverseH t (G.M1 (G.M1 fields)) = + G.M1 . G.M1 <$> gTraverseH @h @g t fields++instance (GTraverseH h g left left',+ GTraverseH h g right right') + => GTraverseH h g (left G.:*: right) (left' G.:*: right') where+ gTraverseH t (left G.:*: right) = + let left' = gTraverseH @h @g t left+ right' = gTraverseH @h @g t right+ in liftA2 (G.:*:) left' right'++instance GTraverseH h g (G.S1 metaSel (G.Rec0 (h bean))) + (G.S1 metaSel (G.Rec0 (g bean))) where+ gTraverseH t (G.M1 (G.K1 (hbean))) =+ G.M1 . G.K1 <$> t hbean +--+--+class GLiftA2Phase a f f' enva env env' | enva -> a, env -> f, env' -> f' where+ gLiftA2Phase :: (forall r. a r -> f r -> f' r) -> enva x -> env x -> env' x++instance GLiftA2Phase a f f' fieldsa fields fields'+ => GLiftA2Phase + a+ f + f'+ (G.D1 metaData (G.C1 metaCons fieldsa)) + (G.D1 metaData (G.C1 metaCons fields)) + (G.D1 metaData (G.C1 metaCons fields')) where+ gLiftA2Phase f (G.M1 (G.M1 fieldsa)) (G.M1 (G.M1 fields)) = + G.M1 (G.M1 (gLiftA2Phase @a @f @f' f fieldsa fields))++instance ( GLiftA2Phase a f f' lefta left left',+ GLiftA2Phase a f f' righta right right'+ ) + => GLiftA2Phase a f f' (lefta G.:*: righta) (left G.:*: right) (left' G.:*: right') where+ gLiftA2Phase f (lefta G.:*: righta) (left G.:*: right) = + let left' = gLiftA2Phase @a @f @f' f lefta left+ right' = gLiftA2Phase @a @f @f' f righta right+ in (G.:*:) left' right'++instance GLiftA2Phase a f f' (G.S1 metaSel (G.Rec0 (a bean)))+ (G.S1 metaSel (G.Rec0 (f bean))) + (G.S1 metaSel (G.Rec0 (f' bean))) where+ gLiftA2Phase f (G.M1 (G.K1 abean)) (G.M1 (G.K1 fgbean)) =+ G.M1 (G.K1 (f abean fgbean))++-- | Class of 2-parameter environments for which it's possible to obtain the+-- names of each field as values.+type DemotableFieldNames :: ((Type -> Type) -> (Type -> Type) -> Type) -> Constraint+class DemotableFieldNames env_ where+ demoteFieldNamesH :: (forall x. String -> h String x) -> env_ (h String) m+ default demoteFieldNamesH + :: ( G.Generic (env_ (h String) m)+ , GDemotableFieldNamesH h (G.Rep (env_ (h String) m)))+ => (forall x. String -> h String x) + -> env_ (h String) m+ demoteFieldNamesH f = G.to (gDemoteFieldNamesH f)++-- | Bring down the field names of the environment to the term level and store+-- them in the accumulator of "Data.Functor.Constant".+demoteFieldNames :: forall env_ m . DemotableFieldNames env_ => env_ (Constant String) m+demoteFieldNames = demoteFieldNamesH Constant++class GDemotableFieldNamesH h env | env -> h where+ gDemoteFieldNamesH :: (forall x. String -> h String x) -> env x+ +instance GDemotableFieldNamesH h fields+ => GDemotableFieldNamesH h (G.D1 metaData (G.C1 metaCons fields)) where+ gDemoteFieldNamesH f = G.M1 (G.M1 (gDemoteFieldNamesH f))++instance ( GDemotableFieldNamesH h left,+ GDemotableFieldNamesH h right) + => GDemotableFieldNamesH h (left G.:*: right) where+ gDemoteFieldNamesH f = + gDemoteFieldNamesH f G.:*: gDemoteFieldNamesH f++instance KnownSymbol name => GDemotableFieldNamesH h (G.S1 (G.MetaSel ('Just name) u v w) (G.Rec0 (h String bean))) where+ gDemoteFieldNamesH f = + G.M1 (G.K1 (f (symbolVal (Proxy @name))))++-- | Modify the outermost phase wrapping each component, while having access to+-- the field name of the component.+--+-- A typical usage is modifying a \"parsing the configuration\" phase so that+-- each component looks into a different section of the global configuration+-- field.+mapPhaseWithFieldNames :: + forall (f :: Type -> Type) (f' :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . + ( Phased env_ + , DemotableFieldNames env_+ , Typeable f+ , Typeable f'+ , Typeable g + , Typeable m ) + => + -- |+ (forall x. String -> f x -> f' x) + -> + -- |+ env_ (Compose f g) m + -> + -- |+ env_ (Compose f' g) m+-- f' first to help annotate the *target* of the transform?+mapPhaseWithFieldNames f env =+ liftA2Phase (\(Constant name) z -> f name z) (runIdentity $ traverseH @env_ (\(Constant z) -> Identity (Compose (Constant z))) demoteFieldNames) env+++-- constructing phases++-- $phasehelpers+--+-- 'bindPhase' and 'skipPhase' are small convenience functions to help build nested compositions of functors.+--++-- $phasehelpers2+--+-- 'fromBare' and 'toBare' are an alternative method to build nested compositions of functors, which relies on "coerce".+--+++-- | Use the result of the previous phase to build the next one.+--+-- Can be useful infix.+--+-- >>> :{+-- type Phases = IO `Compose` IO `Compose` Identity+-- phased :: Phases Int+-- phased =+-- pure 1 `bindPhase` \i1 -> +-- pure 2 `bindPhase` \i2 -> +-- Identity (i1 + i2)+-- :}+--+-- +bindPhase :: forall f g a b . Functor f => f a -> (a -> g b) -> Compose f g b +-- f as first type parameter to help annotate the current phase+bindPhase f k = Compose (f <&> k)++-- | Don't do anything for the current phase, just wrap the next one.+--+-- >>> :{+-- type Phases = IO `Compose` IO `Compose` Identity+-- phased :: Phases Int+-- phased =+-- skipPhase $+-- skipPhase $+-- Identity 1+-- :}+--+skipPhase :: forall f g a . Applicative f => g a -> Compose f g a +-- f as first type parameter to help annotate the current phase+skipPhase g = Compose (pure g)++-- | This type family clears newtypes like 'Compose', 'Identity' and 'Constant' from a composite type,+-- leaving you with a newtypeless nested type as result.+--+-- The idea is that it might be easier to construct values of the \"bare\" version of a composite type,+-- and later coerce them to the newtyped version using 'fromBare'.+--+-- This is mainly intended for defining the nested 'Applicative' \"phases\" of components that live in a 'Phased'+-- environment. It's an alternative to functions like `Dep.Env.bindPhase' and 'Dep.Env.skipPhase'.+type Bare :: Type -> Type+type family Bare x where+ Bare (Compose outer inner x) = Bare (outer (Bare (inner x)))+ Bare (Identity x) = x+ Bare (Const x k) = x+ Bare (Constant x k) = x+ Bare other = other++-- | Convert a value from its bare version to the newtyped one, usually as a step+-- towards inserting it into a 'Phased' environment.+--+-- >>> :{+-- type Phases = IO `Compose` IO `Compose` IO+-- wrapped :: Phases Int = fromBare $ pure $ pure $ pure 3+-- :}+--+-- >>> :{+-- type Phases = Constructor Int+-- wrapped :: Phases Int+-- wrapped = fromBare $ succ+-- :}+--+-- >>> :{+-- type Phases = IO `Compose` Constructor Int+-- wrapped :: Phases Int+-- wrapped = fromBare $ pure $ succ+-- :}+--+fromBare :: Coercible phases (Bare phases) => Bare phases -> phases+fromBare = coerce++-- | Convert from the newtyped value to the bare one. 'fromBare' tends to be more useful.+toBare :: Coercible phases (Bare phases) => phases -> Bare phases+toBare = coerce+++-- | A phase with the effect of \"constructing each component by reading its+-- dependencies from a completed environment\". +--+-- The 'Constructor' phase for an environment will typically be parameterized+-- with the environment itself.+type Constructor (env :: Type) = ((->) env) `Compose` Identity+++-- | Turn an environment-consuming function into a 'Constructor' that can be slotted +-- into some field of a 'Phased' environment.+constructor :: forall r_ m env . (env -> r_ m) -> Constructor env (r_ m)+-- same order of type parameters as Has+constructor = coerce++-- | This is a method of performing dependency injection that doesn't require+-- "Control.Monad.Dep.DepT" at all. In fact, it doesn't require the use of+-- /any/ monad transformer!+--+-- If we have a environment whose fields are functions that construct each+-- component by searching for its dependencies in a \"fully built\" version of+-- the environment, we can \"tie the knot\" to obtain the \"fully built\"+-- environment. This works as long as there aren't any circular dependencies+-- between components.+--+-- Think of it as a version of 'Data.Function.fix' that, instead of \"tying\" a single+-- function, ties a whole record of them.+--+-- The @env_ (Constructor (env_ Identity m)) m@ parameter might be the result of peeling+-- away successive layers of applicative functor composition using 'pullPhase',+-- until only the wiring phase remains.+--+-- >>> :{+-- newtype Foo d = Foo {foo :: String -> d ()} deriving Generic+-- newtype Bar d = Bar {bar :: String -> d ()} deriving Generic+-- makeIOFoo :: MonadIO m => Foo m+-- makeIOFoo = Foo (liftIO . putStrLn)+-- makeBar :: Has Foo m env => env -> Bar m+-- makeBar (asCall -> call) = Bar (call foo)+-- env :: InductiveEnv [Bar,Foo] (Constructor (InductiveEnv [Bar,Foo] Identity IO)) IO+-- env = EmptyEnv +-- & AddDep @Foo (constructor (\_ -> makeIOFoo))+-- & AddDep @Bar (constructor makeBar) +-- envReady :: InductiveEnv [Bar,Foo] Identity IO+-- envReady = fixEnv env+-- :}+--+-- >>> :{+-- bar (dep envReady) "this is bar"+-- :}+-- this is bar+--+fixEnv :: (Phased env_, Typeable env_, Typeable m) => + -- | Environment where each field is wrapped in a 'Constructor' + env_ (Constructor (env_ Identity m)) m -> + -- | Fully constructed environment, ready for use.+ env_ Identity m+fixEnv env = fix (pullPhase env)++-- | An inductively constructed environment with anonymous fields.+--+-- Can be useful for simple tests. Also for converting `Has`-based+-- components into functions that take their dependencies as separate+-- positional parameters.+--+-- > makeController :: (Monad m, Has Logger m env, Has Repository m env) => env -> Controller m+-- > makeController = undefined+-- > makeControllerPositional :: Monad m => Logger m -> Repository m -> Controller m+-- > makeControllerPositional a b = makeController $ addDep @Logger a $ addDep @Repository b $ emptyEnv+-- > makeController' :: (Monad m, Has Logger m env, Has Repository m env) => env -> Controller m+-- > makeController' env = makeControllerPositional (dep env) (dep env)+--+--+data InductiveEnv (rs :: [(Type -> Type) -> Type]) (h :: Type -> Type) (m :: Type -> Type) where+ AddDep :: forall r_ m rs h . h (r_ m) -> InductiveEnv rs h m -> InductiveEnv (r_ : rs) h m+ EmptyEnv :: forall m h . InductiveEnv '[] h m++-- | Unlike the 'AddDep' constructor, this sets @h@ to 'Identity'.+addDep :: forall r_ m rs . r_ m -> InductiveEnv rs Identity m -> InductiveEnv (r_ : rs) Identity m+addDep = AddDep @r_ @m @rs . Identity++-- | Unlike the 'EmptyEnv' constructor, this sets @h@ to 'Identity'.+emptyEnv :: forall m . InductiveEnv '[] Identity m+emptyEnv = EmptyEnv @m @Identity++instance Phased (InductiveEnv rs) where+ traverseH t EmptyEnv = pure EmptyEnv+ traverseH t (AddDep hx rest) = + let headF = t hx+ restF = traverseH t rest+ in AddDep <$> headF <*> restF+ liftA2H t EmptyEnv EmptyEnv = EmptyEnv+ liftA2H t (AddDep ax arest) (AddDep hx hrest) = + AddDep (t ax hx) (liftA2H t arest hrest)+ +-- | Works by searching on the list of types.+instance InductiveEnvFind r_ m rs => Has r_ m (InductiveEnv rs Identity m) where+ dep = inductiveEnvDep++class InductiveEnvFind r_ m rs where+ inductiveEnvDep :: InductiveEnv rs Identity m -> r_ m++instance TypeError (+ Text "The component " + :<>: ShowType r_ + :<>: Text " could not be found in environment.") => InductiveEnvFind r_ m '[] where+ inductiveEnvDep = error "never happens"++instance InductiveEnvFind' (r_ == r_') r_ m (r_' : rs) => InductiveEnvFind r_ m (r_' : rs) where+ inductiveEnvDep = inductiveEnvDep' @(r_ == r_')++class InductiveEnvFind' (matches :: Bool) r_ m rs where+ inductiveEnvDep' :: InductiveEnv rs Identity m -> r_ m++instance InductiveEnvFind' True r_ m (r_ : rs) where+ inductiveEnvDep' (AddDep (Identity r) _) = r++instance InductiveEnvFind r_ m rs => InductiveEnvFind' False r_ m (x : rs) where+ inductiveEnvDep' (AddDep _ rest) = inductiveEnvDep rest++
lib/Dep/Has.hs view
@@ -1,193 +1,193 @@-{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE TypeOperators #-} - --- | This module provides a general-purpose 'Has' class favoring a style in --- which the components of the environment, instead of being bare functions, --- are themselves records or newtypes containing functions. --- --- In this style, the functions that are \"invoked\" from the environment are --- actually record field selectors. These selectors guide the 'Has' class to --- find the correct records in the environment. --- --- >>> :{ --- newtype Logger d = Logger {log :: String -> d ()} --- instance Dep Logger where --- type DefaultFieldName Logger = "logger" --- -- --- data Repository d = Repository --- { select :: String -> d [Int], --- insert :: [Int] -> d () --- } --- instance Dep Repository where --- type DefaultFieldName Repository = "repository" --- -- --- newtype Controller d = Controller {serve :: Int -> d String} --- instance Dep Controller where --- type DefaultFieldName Controller = "controller" --- -- --- type Env :: (Type -> Type) -> Type --- data Env m = Env --- { logger :: Logger m, --- repository :: Repository m, --- controller :: Controller m --- } --- instance Has Logger m (Env m) --- instance Has Repository m (Env m) --- instance Has Controller m (Env m) --- :} --- --- 'Has' can be used in combination with 'MonadDep', like this: --- --- >>> :{ --- mkController :: MonadDep [Has Logger, Has Repository] d env m => Controller m --- mkController = --- Controller \url -> --- useEnv \(asCall -> call) -> do --- call log "I'm going to insert in the db!" --- call select "select * from ..." --- call insert [1, 2, 3, 4] --- return "view" --- :} --- --- 'Has' can also be used independently of 'MonadReader' or 'MonadDep'. Here --- for example the environment is passed as a plain function argument, and @m@ --- doesn't have any constraint other than 'Monad': --- --- >>> :{ --- mkController' :: (Monad m, Has Logger m env, Has Repository m env) => env -> Controller m --- mkController' (asCall -> call) = --- Controller \url -> do --- call log "I'm going to insert in the db!" --- call select "select * from ..." --- call insert [1, 2, 3, 4] --- return "view" --- :} --- --- -module Dep.Has ( - -- * A general-purpose Has - Has (..) - , HasAll - -- * call helper - , asCall - -- * Component defaults - , Dep (..) - ) where - -import Data.Kind -import GHC.Records -import GHC.TypeLits -import Data.Coerce --- import Control.Monad.Reader --- import Control.Monad.Dep.Class - --- | A generic \"Has\" class. When partially applied to a parametrizable --- record-of-functions @r_@, produces a 2-place constraint --- saying that the environment @e@ has the record @r_@ with effect monad @m@. --- --- The constraint can be used on its own, or with "Control.Monad.Dep.Class". -type Has :: ((Type -> Type) -> Type) -> (Type -> Type) -> Type -> Constraint -class Has r_ (m :: Type -> Type) (env :: Type) | env -> m where - -- | Given an environment @e@, produce a record-of-functions parameterized by the environment's effect monad @m@. - -- - -- The hope is that using a selector function on the resulting record will - -- fix the record's type without the need for type annotations. - -- - -- (This will likely not play well with RecordDotSyntax. See also <https://chrisdone.com/posts/import-aliases-field-names/ this import alias trick for avoiding name collisions>.) - dep :: env -> r_ m - default dep :: (Dep r_, HasField (DefaultFieldName r_) env u, Coercible u (r_ m)) => env -> r_ m - dep env = coerce . getField @(DefaultFieldName r_) $ env - --- | When partially applied to a type-level list @rs_@ of parametrizable records-of-functions, --- produces a 2-place constraint saying that the environment @e@ has all the --- records @rs_@ with effect monad @m@. -type HasAll :: [(Type -> Type) -> Type] -> (Type -> Type) -> Type -> Constraint -type family HasAll rs_ m e where - HasAll '[] m e = () - HasAll (r_ : rs_) m e = (Has r_ m e, HasAll rs_ m e) - --- | Transforms an environment with suitable 'Has' instances into a \"helper\" --- function that looks in the environment for the arguments of other functions. --- Typically, the \"helped\" functions will be record field selectors: --- --- >>> :{ --- data SomeRecord m = SomeRecord { someSelector :: String -> m () } --- data Env m = Env --- { someRecord :: SomeRecord m --- } --- instance Has SomeRecord m (Env m) where --- dep (Env{someRecord}) = someRecord --- :} --- --- In practice, this means that you can write @call someSelector@ instead of @someSelector (dep --- env)@: --- --- >>> :{ --- twoInvocations :: (IO (), IO ()) --- twoInvocations = --- let env :: Env IO = Env { someRecord = SomeRecord { someSelector = putStrLn } } --- call = asCall env --- in (someSelector (dep env) "foo", call someSelector "foo") --- :} --- --- Using 'asCall' in a view pattern avoids having to name the --- environment: --- --- --- >>> :{ --- functionThatCalls :: Has SomeRecord m e => e -> m () --- functionThatCalls (asCall -> call) = call someSelector "foo" --- :} --- -asCall :: forall env m . env -> forall r_ x. Has r_ m env => (r_ m -> x) -> x -asCall env = \f -> f (dep env) - --- | Parametrizable records-of-functions can be given an instance of this --- typeclass to specify the default field name 'Has' expects for the component --- in the environment record. --- --- This allows defining 'Has' instances with empty bodies, thanks to --- @DefaultSignatures@. -type Dep :: ((Type -> Type) -> Type) -> Constraint -class Dep r_ where - -- The Char kind would be useful here, to lowercase the first letter of the - -- k type and use it as the default preferred field name. - type DefaultFieldName r_ :: Symbol - --- $setup --- --- >>> :set -XTypeApplications --- >>> :set -XMultiParamTypeClasses --- >>> :set -XImportQualifiedPost --- >>> :set -XTemplateHaskell --- >>> :set -XStandaloneKindSignatures --- >>> :set -XNamedFieldPuns --- >>> :set -XFunctionalDependencies --- >>> :set -XFlexibleContexts --- >>> :set -XDataKinds --- >>> :set -XBlockArguments --- >>> :set -XFlexibleInstances --- >>> :set -XTypeFamilies --- >>> :set -XDeriveGeneric --- >>> :set -XViewPatterns --- >>> :set -XScopedTypeVariables --- >>> import Data.Kind --- >>> import Control.Monad.Dep --- >>> import GHC.Generics (Generic) --- - +{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TypeOperators #-}++-- | This module provides a general-purpose 'Has' class favoring a style in+-- which the components of the environment, instead of being bare functions,+-- are themselves records or newtypes containing functions.+--+-- In this style, the functions that are \"invoked\" from the environment are+-- actually record field selectors. These selectors guide the 'Has' class to+-- find the correct records in the environment.+--+-- >>> :{+-- newtype Logger d = Logger {log :: String -> d ()}+-- instance Dep Logger where+-- type DefaultFieldName Logger = "logger"+-- --+-- data Repository d = Repository+-- { select :: String -> d [Int],+-- insert :: [Int] -> d ()+-- }+-- instance Dep Repository where+-- type DefaultFieldName Repository = "repository"+-- --+-- newtype Controller d = Controller {serve :: Int -> d String}+-- instance Dep Controller where+-- type DefaultFieldName Controller = "controller"+-- --+-- type Env :: (Type -> Type) -> Type+-- data Env m = Env+-- { logger :: Logger m,+-- repository :: Repository m,+-- controller :: Controller m+-- }+-- instance Has Logger m (Env m)+-- instance Has Repository m (Env m)+-- instance Has Controller m (Env m)+-- :}+-- +-- 'Has' can be used in combination with 'MonadDep', like this:+--+-- >>> :{+-- mkController :: MonadDep [Has Logger, Has Repository] d env m => Controller m+-- mkController =+-- Controller \url -> +-- useEnv \(asCall -> call) -> do+-- call log "I'm going to insert in the db!"+-- call select "select * from ..."+-- call insert [1, 2, 3, 4]+-- return "view"+-- :}+--+-- 'Has' can also be used independently of 'MonadReader' or 'MonadDep'. Here+-- for example the environment is passed as a plain function argument, and @m@+-- doesn't have any constraint other than 'Monad':+--+-- >>> :{+-- mkController' :: (Monad m, Has Logger m env, Has Repository m env) => env -> Controller m+-- mkController' (asCall -> call) =+-- Controller \url -> do+-- call log "I'm going to insert in the db!"+-- call select "select * from ..."+-- call insert [1, 2, 3, 4]+-- return "view"+-- :}+--+--+module Dep.Has (+ -- * A general-purpose Has+ Has (..)+ , HasAll+ -- * call helper+ , asCall+ -- * Component defaults+ , Dep (..)+ ) where++import Data.Kind+import GHC.Records+import GHC.TypeLits+import Data.Coerce+-- import Control.Monad.Reader+-- import Control.Monad.Dep.Class++-- | A generic \"Has\" class. When partially applied to a parametrizable+-- record-of-functions @r_@, produces a 2-place constraint +-- saying that the environment @e@ has the record @r_@ with effect monad @m@.+--+-- The constraint can be used on its own, or with "Control.Monad.Dep.Class".+type Has :: ((Type -> Type) -> Type) -> (Type -> Type) -> Type -> Constraint+class Has r_ (m :: Type -> Type) (env :: Type) | env -> m where+ -- | Given an environment @e@, produce a record-of-functions parameterized by the environment's effect monad @m@.+ --+ -- The hope is that using a selector function on the resulting record will+ -- fix the record's type without the need for type annotations.+ --+ -- (This will likely not play well with RecordDotSyntax. See also <https://chrisdone.com/posts/import-aliases-field-names/ this import alias trick for avoiding name collisions>.)+ dep :: env -> r_ m+ default dep :: (Dep r_, HasField (DefaultFieldName r_) env u, Coercible u (r_ m)) => env -> r_ m+ dep env = coerce . getField @(DefaultFieldName r_) $ env++-- | When partially applied to a type-level list @rs_@ of parametrizable records-of-functions, +-- produces a 2-place constraint saying that the environment @e@ has all the+-- records @rs_@ with effect monad @m@.+type HasAll :: [(Type -> Type) -> Type] -> (Type -> Type) -> Type -> Constraint+type family HasAll rs_ m e where+ HasAll '[] m e = ()+ HasAll (r_ : rs_) m e = (Has r_ m e, HasAll rs_ m e)++-- | Transforms an environment with suitable 'Has' instances into a \"helper\"+-- function that looks in the environment for the arguments of other functions.+-- Typically, the \"helped\" functions will be record field selectors:+--+-- >>> :{+-- data SomeRecord m = SomeRecord { someSelector :: String -> m () }+-- data Env m = Env+-- { someRecord :: SomeRecord m+-- }+-- instance Has SomeRecord m (Env m) where+-- dep (Env{someRecord}) = someRecord+-- :}+--+-- In practice, this means that you can write @call someSelector@ instead of @someSelector (dep+-- env)@:+--+-- >>> :{+-- twoInvocations :: (IO (), IO ()) +-- twoInvocations = +-- let env :: Env IO = Env { someRecord = SomeRecord { someSelector = putStrLn } }+-- call = asCall env+-- in (someSelector (dep env) "foo", call someSelector "foo") +-- :}+--+-- Using 'asCall' in a view pattern avoids having to name the+-- environment:+--+--+-- >>> :{+-- functionThatCalls :: Has SomeRecord m e => e -> m ()+-- functionThatCalls (asCall -> call) = call someSelector "foo"+-- :}+--+asCall :: forall env m . env -> forall r_ x. Has r_ m env => (r_ m -> x) -> x+asCall env = \f -> f (dep env)++-- | Parametrizable records-of-functions can be given an instance of this+-- typeclass to specify the default field name 'Has' expects for the component+-- in the environment record.+--+-- This allows defining 'Has' instances with empty bodies, thanks to+-- @DefaultSignatures@.+type Dep :: ((Type -> Type) -> Type) -> Constraint+class Dep r_ where+ -- The Char kind would be useful here, to lowercase the first letter of the+ -- k type and use it as the default preferred field name.+ type DefaultFieldName r_ :: Symbol++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XImportQualifiedPost+-- >>> :set -XTemplateHaskell+-- >>> :set -XStandaloneKindSignatures+-- >>> :set -XNamedFieldPuns+-- >>> :set -XFunctionalDependencies+-- >>> :set -XFlexibleContexts+-- >>> :set -XDataKinds+-- >>> :set -XBlockArguments+-- >>> :set -XFlexibleInstances+-- >>> :set -XTypeFamilies+-- >>> :set -XDeriveGeneric+-- >>> :set -XViewPatterns+-- >>> :set -XScopedTypeVariables+-- >>> import Data.Kind+-- >>> import Control.Monad.Dep+-- >>> import GHC.Generics (Generic)+--+
lib/Dep/Tagged.hs view
@@ -1,91 +1,91 @@-{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ExplicitForAll #-} - --- | Companion module to "Dep.Has" for disambiguanting record components within an environment. --- --- Similar in purpose to the [Qualifier annotation](https://docs.spring.io/spring-framework/docs/current/javadoc-api/org/springframework/beans/factory/annotation/Qualifier.html) in Java Spring. --- --- >>> :{ --- newtype Foo d = Foo {foo :: String -> d ()} deriving Generic --- makeIOFoo :: MonadIO m => Foo m --- makeIOFoo = Foo (liftIO . putStrLn) --- makeIOFoo' :: MonadIO m => Foo m --- makeIOFoo' = Foo (\_ -> liftIO $ putStrLn "this is secondary") --- env :: InductiveEnv '[Foo, Tagged "secondary" Foo] Identity IO --- env = AddDep @Foo (Identity makeIOFoo) --- $ AddDep @(Tagged "secondary" Foo) (Identity (tagged makeIOFoo')) --- $ EmptyEnv --- :} --- --- >>> :{ --- foo (dep env) "this is foo" --- :} --- this is foo --- --- >>> :{ --- foo (untag @"secondary" (dep env)) "this is foo" --- :} --- this is secondary --- --- --- When using functions from "Dep.SimpleAdvice" (which tend to depend on coercions) with 'Tagged' components, remember to import the newtype's constructor. -module Dep.Tagged - ( - Tagged (..), - tagged, - untag - ) -where - -import Data.Kind -import Data.Typeable -import GHC.Generics qualified as G - --- | Very similar to the @Data.Tagged@ type from the \"tagged\" package, but --- with an extra monad type argument. The intended use is to disambiguate --- record components within an environment, when there are multiple records of the same --- type. -type Tagged :: k -> ((Type -> Type) -> Type) -> (Type -> Type) -> Type -newtype Tagged s r_ m = Tagged {unTagged :: r_ m} - deriving - ( - G.Generic, - Typeable - ) - --- When inserting into an environment a component that you want to disambiguate, provide the the tag using a type variable and then supply the record value. -tagged :: forall s r_ m . r_ m -> Tagged s r_ m -tagged = Tagged - --- | Alias for 'unTagged'. --- --- When invoking a method from a tagged dependency, --- provide the tag using a type application and compose with the record selector. -untag :: Tagged s r_ m -> r_ m -untag = unTagged - --- $setup --- --- >>> :set -XTypeApplications --- >>> :set -XMultiParamTypeClasses --- >>> :set -XImportQualifiedPost --- >>> :set -XTemplateHaskell --- >>> :set -XStandaloneKindSignatures --- >>> :set -XNamedFieldPuns --- >>> :set -XFunctionalDependencies --- >>> :set -XFlexibleContexts --- >>> :set -XDataKinds --- >>> :set -XBlockArguments --- >>> :set -XFlexibleInstances --- >>> :set -XTypeFamilies --- >>> :set -XDeriveGeneric --- >>> :set -XViewPatterns --- >>> import Data.Kind --- >>> import Control.Monad.IO.Class --- >>> import GHC.Generics (Generic) --- >>> import Dep.Has --- >>> import Dep.Env +{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ExplicitForAll #-}++-- | Companion module to "Dep.Has" for disambiguanting record components within an environment.+--+-- Similar in purpose to the [Qualifier annotation](https://docs.spring.io/spring-framework/docs/current/javadoc-api/org/springframework/beans/factory/annotation/Qualifier.html) in Java Spring.+--+-- >>> :{+-- newtype Foo d = Foo {foo :: String -> d ()} deriving Generic+-- makeIOFoo :: MonadIO m => Foo m+-- makeIOFoo = Foo (liftIO . putStrLn)+-- makeIOFoo' :: MonadIO m => Foo m+-- makeIOFoo' = Foo (\_ -> liftIO $ putStrLn "this is secondary")+-- env :: InductiveEnv '[Foo, Tagged "secondary" Foo] Identity IO+-- env = AddDep @Foo (Identity makeIOFoo)+-- $ AddDep @(Tagged "secondary" Foo) (Identity (tagged makeIOFoo'))+-- $ EmptyEnv +-- :}+--+-- >>> :{+-- foo (dep env) "this is foo"+-- :}+-- this is foo+--+-- >>> :{+-- foo (untag @"secondary" (dep env)) "this is foo"+-- :}+-- this is secondary+--+--+-- When using functions from "Dep.SimpleAdvice" (which tend to depend on coercions) with 'Tagged' components, remember to import the newtype's constructor.+module Dep.Tagged+ (+ Tagged (..),+ tagged,+ untag+ )+where++import Data.Kind+import Data.Typeable+import GHC.Generics qualified as G++-- | Very similar to the @Data.Tagged@ type from the \"tagged\" package, but+-- with an extra monad type argument. The intended use is to disambiguate+-- record components within an environment, when there are multiple records of the same+-- type.+type Tagged :: k -> ((Type -> Type) -> Type) -> (Type -> Type) -> Type+newtype Tagged s r_ m = Tagged {unTagged :: r_ m}+ deriving+ ( + G.Generic,+ Typeable+ )++-- When inserting into an environment a component that you want to disambiguate, provide the the tag using a type variable and then supply the record value. +tagged :: forall s r_ m . r_ m -> Tagged s r_ m+tagged = Tagged++-- | Alias for 'unTagged'.+--+-- When invoking a method from a tagged dependency,+-- provide the tag using a type application and compose with the record selector.+untag :: Tagged s r_ m -> r_ m+untag = unTagged++-- $setup+--+-- >>> :set -XTypeApplications+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XImportQualifiedPost+-- >>> :set -XTemplateHaskell+-- >>> :set -XStandaloneKindSignatures+-- >>> :set -XNamedFieldPuns+-- >>> :set -XFunctionalDependencies+-- >>> :set -XFlexibleContexts+-- >>> :set -XDataKinds+-- >>> :set -XBlockArguments+-- >>> :set -XFlexibleInstances+-- >>> :set -XTypeFamilies+-- >>> :set -XDeriveGeneric+-- >>> :set -XViewPatterns+-- >>> import Data.Kind+-- >>> import Control.Monad.IO.Class+-- >>> import GHC.Generics (Generic)+-- >>> import Dep.Has+-- >>> import Dep.Env --
test/doctests.hs view
@@ -1,12 +1,12 @@-module Main (main) where - -import Test.DocTest -main = doctest [ - "-ilib", - "lib/Control/Monad/Dep.hs", - "lib/Control/Monad/Dep/Class.hs", - "lib/Dep/Has.hs", - "lib/Dep/Env.hs", - "lib/Dep/Tagged.hs" - ] - +module Main (main) where++import Test.DocTest+main = doctest [+ "-ilib", + "lib/Control/Monad/Dep.hs", + "lib/Control/Monad/Dep/Class.hs", + "lib/Dep/Has.hs", + "lib/Dep/Env.hs",+ "lib/Dep/Tagged.hs"+ ]+
test/tests.hs view
@@ -1,292 +1,292 @@-{-# 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 DataKinds #-} - -module Main (main) where - -import Control.Monad.Dep -import Control.Monad.Reader -import Control.Monad.Writer -import Data.Kind -import Data.Coerce -import Data.List (intercalate) -import Rank2 qualified -import Rank2.TH qualified -import Test.Tasty -import Test.Tasty.HUnit -import Prelude hiding (log) - --- Some helper typeclasses. --- --- Has-style typeclasses can be provided to avoid depending on concrete --- environments. --- Note that the environment determines the monad. -type HasLogger :: (Type -> Type) -> Type -> Constraint -class HasLogger d e | e -> d where - logger :: e -> String -> d () - --- Possible convenience function to avoid having to use ask before logging --- Worth the extra boilerplate, or not? ---logger' :: (MonadReader e m, LiftDep d m, HasLogger e d) => String -> m () -loggerD :: MonadDep '[HasLogger] d e m => String -> m () -loggerD msg = asks logger >>= \f -> liftD $ f msg - -type HasRepository :: (Type -> Type) -> Type -> Constraint -class HasRepository d e | e -> d where - repository :: e -> Int -> d () - --- Some possible implementations. --- --- An implementation of the controller, done programming against interfaces --- (well, against typeclasses). --- Polymorphic on the monad. ---mkController :: (MonadReader e m, LiftDep d m, HasLogger e d, HasRepository e d) => Int -> m String -mkController :: MonadDep '[HasLogger, HasRepository] d e m => Int -> m String -mkController x = do - e <- ask - liftD $ logger e "I'm going to insert in the db!" - liftD $ repository e x - return "view" - -usesLoggerD :: MonadDep '[HasLogger, HasRepository] d e m => Int -> m String -usesLoggerD i = do - loggerD "I'm calling the logger!" - return "foo" - --- A "real" logger implementation that interacts with the external world. -mkStdoutLogger :: MonadIO m => String -> m () -mkStdoutLogger msg = liftIO (putStrLn msg) - --- A "real" repository implementation ---mkStdoutRepository :: (MonadReader e m, LiftDep d m, HasLogger e d, MonadIO m) => Int -> m () -mkStdoutRepository :: (MonadDep '[HasLogger] d e m, MonadIO m) => Int -> m () -mkStdoutRepository entity = do - e <- ask - liftD $ logger e "I'm going to write the entity!" - liftIO $ print entity - --- The traces we accumulate from the fakes during tests -type TestTrace = ([String], [Int]) - --- A "fake". A pure implementation for tests. -mkFakeLogger :: MonadWriter TestTrace m => String -> m () -mkFakeLogger msg = tell ([msg], []) - --- Ditto. ---mkFakeRepository :: (MonadReader e m, LiftDep d m, HasLogger e d, MonadWriter TestTrace m) => Int -> m () -mkFakeRepository :: (MonadDep '[HasLogger] d e m, MonadWriter TestTrace m) => Int -> m () -mkFakeRepository entity = do - e <- ask - liftD $ logger e "I'm going to write the entity!" - tell ([], [entity]) - --- --- --- Here we define a monomorphic environment working on IO -type EnvIO :: Type -data EnvIO = EnvIO - { _loggerIO :: String -> IO (), - _repositoryIO :: Int -> IO () - } - -envIO' :: EnvIO -envIO' = - let _loggerIO = mkStdoutLogger - _repositoryIO i = print "this is the repo" - in EnvIO {_loggerIO, _repositoryIO} - -instance HasLogger IO EnvIO where - logger = _loggerIO - -instance HasRepository IO EnvIO where - repository = _repositoryIO - --- mkController works both with DepT and with ReaderT + monomorphic environment -runningTheControllerInReaderT :: IO String -runningTheControllerInReaderT = mkController 5 `runReaderT` envIO' - -mkControllerIO' :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String -mkControllerIO' = mkController - --- In the monomorphic environment, the controller function lives "separate", --- having access to the logger and the repository through the ReaderT --- environment. --- --- The question is: the repository function *also* needs to know about the --- logger! Shouldn't it be aware of the ReaderT environment as well? Why --- privilege the controller function in such a manner? --- --- In a sufficiently complex app, the diverse functions will form a DAG of --- dependencies between each other. So it would be nice if the functions were --- treated uniformly, all having access to (views of) the environment record. --- --- no need for this now that we have MonadDep... just use the conventional mkController -mkControllerIO :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String -mkControllerIO x = do - e <- ask - liftIO $ logger e "I'm going to insert in the db!" - liftIO $ repository e x - return "view" - --- --- --- Here we define some polymorphic environments, which are basically --- records-of-functions parameterized by an effect monad. -type Env :: (Type -> Type) -> Type -data Env m = Env - { _logger :: String -> m (), - _repository :: Int -> m (), - _controller :: Int -> m String - } - -$(Rank2.TH.deriveFunctor ''Env) - --- If our environment is parmeterized by the monad m, then logging is done in --- m. -instance HasLogger m (Env m) where - logger = _logger - -instance HasRepository m (Env m) where - repository = _repository - --- This bigger environment is for demonstrating how to "nest" environments. -type BiggerEnv :: (Type -> Type) -> Type -data BiggerEnv m = BiggerEnv - { _inner :: Env m, - _extra :: Int -> m Int - } - -$(Rank2.TH.deriveFunctor ''BiggerEnv) - --- --- --- Creating environment values and commiting to a concrete monad. --- --- This is the first time DepT is used in this module. --- Note that it is only here where we settle for a concrete monad for the --- polymorphic environments. -env :: Env (DepT Env (Writer TestTrace)) -env = - let _logger = mkFakeLogger - _repository = mkFakeRepository - _controller = mkController - in Env {_logger, _repository, _controller} - --- An IO variant -envIO :: Env (DepT Env IO) -envIO = - let _logger = mkStdoutLogger - _repository = mkStdoutRepository - _controller = mkController - in Env {_logger, _repository, _controller} - -biggerEnv :: BiggerEnv (DepT BiggerEnv (Writer TestTrace)) -biggerEnv = - let -- We embed the small environment into the bigger one using "zoomEnv" - -- and the rank-2 fmap that allows us to change the monad which - -- parameterized the environment. - -- - -- _inner' = (Rank2.<$>) (withDepT (Rank2.<$>) inner) env, - _inner' = zoomEnv (Rank2.<$>) _inner env - _extra = pure - in BiggerEnv {_inner = _inner', _extra} - -biggerEnvIO :: BiggerEnv (DepT BiggerEnv IO) -biggerEnvIO = - let _inner' = zoomEnv (Rank2.<$>) _inner envIO - _extra = pure - in BiggerEnv {_inner = _inner', _extra} - -expected :: TestTrace -expected = (["I'm going to insert in the db!", "I'm going to write the entity!"], [7]) - --- --- --- Experiment about adding instrumetation -class Instrumentable e m r | r -> e m where - instrument :: - ( forall x. - HasLogger (DepT e m) (e (DepT e m)) => - [String] -> - DepT e m x -> - DepT e m x - ) -> - r -> - r - -instance HasLogger (DepT e m) (e (DepT e m)) => Instrumentable e m (DepT e m x) where - instrument f d = f [] d - -instance (Instrumentable e m r, Show a) => Instrumentable e m (a -> r) where - instrument f ar = - let instrument' = instrument @e @m @r - in \a -> instrument' (\names d -> f (show a : names) d) (ar a) - -instrumentedEnv :: Env (DepT Env (Writer TestTrace)) -instrumentedEnv = - let loggingAdvice args action = do - e <- ask - logger e $ "advice before: " ++ intercalate "," args - r <- action - logger e $ "advice after" - pure r - in env {_controller = instrument loggingAdvice (_controller env)} - -expectedInstrumented :: TestTrace -expectedInstrumented = (["advice before: 7", "I'm going to insert in the db!", "I'm going to write the entity!", "advice after"], [7]) - - --- --- --- -boringAction :: DepT NilEnv IO () -boringAction = lift (putStrLn "") --- --- --- - --- --- --- checking that coerce works on environments... -newtype NilEnv' m = NilEnv' (NilEnv m) - -toBeCoerced :: DepT NilEnv IO () -toBeCoerced = pure () - -toBeCoerced' :: DepT NilEnv' IO () -toBeCoerced' = coerce toBeCoerced - -toBeCoerced'' :: DepT NilEnv IO () -toBeCoerced'' = coerce toBeCoerced' --- --- --- - - -tests :: TestTree -tests = - testGroup - "All" - [ testCase "hopeThisWorks" $ - assertEqual "" expected $ - execWriter $ runDepT (do e <- ask; (_controller . _inner) e 7) biggerEnv, - testCase "hopeAOPWorks" $ - assertEqual "" expectedInstrumented $ - execWriter $ runDepT (do e <- ask; _controller e 7) instrumentedEnv, - testCase "hopeLoggerDWorks" $ - assertEqual "" (["foo"],[]) $ - execWriter $ loggerD "foo" `runDepT` env - ] - -main :: IO () -main = defaultMain tests +{-# 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 DataKinds #-}++module Main (main) where++import Control.Monad.Dep+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Kind+import Data.Coerce+import Data.List (intercalate)+import Rank2 qualified+import Rank2.TH qualified+import Test.Tasty+import Test.Tasty.HUnit+import Prelude hiding (log)++-- Some helper typeclasses.+--+-- Has-style typeclasses can be provided to avoid depending on concrete+-- environments.+-- Note that the environment determines the monad.+type HasLogger :: (Type -> Type) -> Type -> Constraint+class HasLogger d e | e -> d where+ logger :: e -> String -> d ()++-- Possible convenience function to avoid having to use ask before logging+-- Worth the extra boilerplate, or not?+--logger' :: (MonadReader e m, LiftDep d m, HasLogger e d) => String -> m ()+loggerD :: MonadDep '[HasLogger] d e m => String -> m ()+loggerD msg = asks logger >>= \f -> liftD $ f msg++type HasRepository :: (Type -> Type) -> Type -> Constraint+class HasRepository d e | e -> d where+ repository :: e -> Int -> d ()++-- Some possible implementations.+--+-- An implementation of the controller, done programming against interfaces+-- (well, against typeclasses).+-- Polymorphic on the monad.+--mkController :: (MonadReader e m, LiftDep d m, HasLogger e d, HasRepository e d) => Int -> m String+mkController :: MonadDep '[HasLogger, HasRepository] d e m => Int -> m String+mkController x = do+ e <- ask+ liftD $ logger e "I'm going to insert in the db!"+ liftD $ repository e x+ return "view"++usesLoggerD :: MonadDep '[HasLogger, HasRepository] d e m => Int -> m String+usesLoggerD i = do+ loggerD "I'm calling the logger!"+ return "foo"++-- A "real" logger implementation that interacts with the external world.+mkStdoutLogger :: MonadIO m => String -> m ()+mkStdoutLogger msg = liftIO (putStrLn msg)++-- A "real" repository implementation+--mkStdoutRepository :: (MonadReader e m, LiftDep d m, HasLogger e d, MonadIO m) => Int -> m ()+mkStdoutRepository :: (MonadDep '[HasLogger] d e m, MonadIO m) => Int -> m ()+mkStdoutRepository entity = do+ e <- ask+ liftD $ logger e "I'm going to write the entity!"+ liftIO $ print entity++-- The traces we accumulate from the fakes during tests+type TestTrace = ([String], [Int])++-- A "fake". A pure implementation for tests.+mkFakeLogger :: MonadWriter TestTrace m => String -> m ()+mkFakeLogger msg = tell ([msg], [])++-- Ditto.+--mkFakeRepository :: (MonadReader e m, LiftDep d m, HasLogger e d, MonadWriter TestTrace m) => Int -> m ()+mkFakeRepository :: (MonadDep '[HasLogger] d e m, MonadWriter TestTrace m) => Int -> m ()+mkFakeRepository entity = do+ e <- ask+ liftD $ logger e "I'm going to write the entity!"+ tell ([], [entity])++--+--+-- Here we define a monomorphic environment working on IO+type EnvIO :: Type+data EnvIO = EnvIO+ { _loggerIO :: String -> IO (),+ _repositoryIO :: Int -> IO ()+ }++envIO' :: EnvIO+envIO' =+ let _loggerIO = mkStdoutLogger+ _repositoryIO i = print "this is the repo"+ in EnvIO {_loggerIO, _repositoryIO}++instance HasLogger IO EnvIO where+ logger = _loggerIO++instance HasRepository IO EnvIO where+ repository = _repositoryIO++-- mkController works both with DepT and with ReaderT + monomorphic environment+runningTheControllerInReaderT :: IO String+runningTheControllerInReaderT = mkController 5 `runReaderT` envIO'++mkControllerIO' :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String+mkControllerIO' = mkController++-- In the monomorphic environment, the controller function lives "separate",+-- having access to the logger and the repository through the ReaderT+-- environment.+--+-- The question is: the repository function *also* needs to know about the+-- logger! Shouldn't it be aware of the ReaderT environment as well? Why+-- privilege the controller function in such a manner?+--+-- In a sufficiently complex app, the diverse functions will form a DAG of+-- dependencies between each other. So it would be nice if the functions were+-- treated uniformly, all having access to (views of) the environment record.+--+-- no need for this now that we have MonadDep... just use the conventional mkController+mkControllerIO :: (HasLogger IO e, HasRepository IO e) => Int -> ReaderT e IO String+mkControllerIO x = do+ e <- ask+ liftIO $ logger e "I'm going to insert in the db!"+ liftIO $ repository e x+ return "view"++--+--+-- Here we define some polymorphic environments, which are basically+-- records-of-functions parameterized by an effect monad.+type Env :: (Type -> Type) -> Type+data Env m = Env+ { _logger :: String -> m (),+ _repository :: Int -> m (),+ _controller :: Int -> m String+ }++$(Rank2.TH.deriveFunctor ''Env)++-- If our environment is parmeterized by the monad m, then logging is done in+-- m.+instance HasLogger m (Env m) where+ logger = _logger++instance HasRepository m (Env m) where+ repository = _repository++-- This bigger environment is for demonstrating how to "nest" environments.+type BiggerEnv :: (Type -> Type) -> Type+data BiggerEnv m = BiggerEnv+ { _inner :: Env m,+ _extra :: Int -> m Int+ }++$(Rank2.TH.deriveFunctor ''BiggerEnv)++--+--+-- Creating environment values and commiting to a concrete monad.+--+-- This is the first time DepT is used in this module.+-- Note that it is only here where we settle for a concrete monad for the+-- polymorphic environments.+env :: Env (DepT Env (Writer TestTrace))+env =+ let _logger = mkFakeLogger+ _repository = mkFakeRepository+ _controller = mkController+ in Env {_logger, _repository, _controller}++-- An IO variant+envIO :: Env (DepT Env IO)+envIO =+ let _logger = mkStdoutLogger+ _repository = mkStdoutRepository+ _controller = mkController+ in Env {_logger, _repository, _controller}++biggerEnv :: BiggerEnv (DepT BiggerEnv (Writer TestTrace))+biggerEnv =+ let -- We embed the small environment into the bigger one using "zoomEnv"+ -- and the rank-2 fmap that allows us to change the monad which+ -- parameterized the environment.+ --+ -- _inner' = (Rank2.<$>) (withDepT (Rank2.<$>) inner) env,+ _inner' = zoomEnv (Rank2.<$>) _inner env+ _extra = pure+ in BiggerEnv {_inner = _inner', _extra}++biggerEnvIO :: BiggerEnv (DepT BiggerEnv IO)+biggerEnvIO =+ let _inner' = zoomEnv (Rank2.<$>) _inner envIO+ _extra = pure+ in BiggerEnv {_inner = _inner', _extra}++expected :: TestTrace+expected = (["I'm going to insert in the db!", "I'm going to write the entity!"], [7])++--+--+-- Experiment about adding instrumetation+class Instrumentable e m r | r -> e m where+ instrument ::+ ( forall x.+ HasLogger (DepT e m) (e (DepT e m)) =>+ [String] ->+ DepT e m x ->+ DepT e m x+ ) ->+ r ->+ r++instance HasLogger (DepT e m) (e (DepT e m)) => Instrumentable e m (DepT e m x) where+ instrument f d = f [] d++instance (Instrumentable e m r, Show a) => Instrumentable e m (a -> r) where+ instrument f ar =+ let instrument' = instrument @e @m @r+ in \a -> instrument' (\names d -> f (show a : names) d) (ar a)++instrumentedEnv :: Env (DepT Env (Writer TestTrace))+instrumentedEnv =+ let loggingAdvice args action = do+ e <- ask+ logger e $ "advice before: " ++ intercalate "," args+ r <- action+ logger e $ "advice after"+ pure r+ in env {_controller = instrument loggingAdvice (_controller env)}++expectedInstrumented :: TestTrace+expectedInstrumented = (["advice before: 7", "I'm going to insert in the db!", "I'm going to write the entity!", "advice after"], [7])+++--+--+--+boringAction :: DepT NilEnv IO ()+boringAction = lift (putStrLn "")+--+--+--++--+--+-- checking that coerce works on environments...+newtype NilEnv' m = NilEnv' (NilEnv m)++toBeCoerced :: DepT NilEnv IO ()+toBeCoerced = pure ()++toBeCoerced' :: DepT NilEnv' IO ()+toBeCoerced' = coerce toBeCoerced++toBeCoerced'' :: DepT NilEnv IO ()+toBeCoerced'' = coerce toBeCoerced'+--+--+--+++tests :: TestTree+tests =+ testGroup+ "All"+ [ testCase "hopeThisWorks" $+ assertEqual "" expected $+ execWriter $ runDepT (do e <- ask; (_controller . _inner) e 7) biggerEnv,+ testCase "hopeAOPWorks" $+ assertEqual "" expectedInstrumented $+ execWriter $ runDepT (do e <- ask; _controller e 7) instrumentedEnv,+ testCase "hopeLoggerDWorks" $+ assertEqual "" (["foo"],[]) $+ execWriter $ loggerD "foo" `runDepT` env+ ]++main :: IO ()+main = defaultMain tests
test/tests_curry.hs view
@@ -1,139 +1,139 @@-{-# 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 DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DerivingStrategies #-} - -module Main (main) where - -import Control.Monad.Dep -import Control.Monad.Reader -import Control.Monad.Writer -import Data.Kind -import Data.Coerce -import Data.List (intercalate) -import Rank2 qualified -import Rank2.TH qualified -import Test.Tasty -import Test.Tasty.HUnit -import Prelude hiding (log) -import Data.SOP -import Data.SOP.NP - -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 - -instance Monad m => Multicurryable '[] e m r (DepT e m r) where - type DownToBaseMonad '[] e m r (DepT e m r) = m r - multiuncurry action Nil = action - multicurry f = f Nil - _runFromEnv producer extractor = do - e <- producer - runDepT (extractor e) e - -instance Multicurryable as e m r curried => Multicurryable (a ': as) e m r (a -> curried) where - type DownToBaseMonad (a ': as) e m r (a -> curried) = a -> DownToBaseMonad as e m r curried - multiuncurry f (I a :* as) = multiuncurry @as @e @m @r @curried (f a) as - multicurry f a = multicurry @as @e @m @r @curried (f . (:*) (I a)) - _runFromEnv producer extractor a = _runFromEnv @as @e @m @r @curried producer (\f -> extractor f a) - -class Multicurryable as e m r curried => Deceivable as newtyped e m r curried where - type Deceive as newtyped e m r curried :: Type - deceive :: (e (DepT e m) -> newtyped) -> Deceive as newtyped e m r curried -> curried - -instance Monad m => Deceivable '[] newtyped e m r (DepT e m r) where - type Deceive '[] newtyped e m r (DepT e m r) = ReaderT newtyped m r - deceive f action = DepT (withReaderT f action) - -instance Deceivable as newtyped e m r curried => Deceivable (a ': as) newtyped e m r (a -> curried) where - type Deceive (a ': as) newtyped e m r (a -> curried) = a -> Deceive as newtyped e m r curried - deceive f g a = deceive @as @newtyped @e @m @r f (g a) - --- --- --- -type HasLogger :: (Type -> Type) -> Type -> Constraint -class HasLogger m em | em -> m where - logger :: em -> String -> m () -type HasIntermediate :: (Type -> Type) -> Type -> Constraint -class HasIntermediate m em | em -> m where - intermediate :: em -> String -> m () -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 - -envW :: Env (DepT Env (Writer [String])) -envW = Env - { - _logger1 = - \_ -> tell ["logger 1"], - _logger2 = - \_ -> tell ["logger 2"], - _intermediate = - \_ -> do e <- ask ; liftD $ logger e "foo", - _controllerA = - \_ -> do e <- ask; liftD $ logger e "foo" ; liftD $ intermediate e "foo", - _controllerB = - deceive Switcheroo $ - \_ -> do e <- ask; liftD $ logger e "foo" ; liftD $ intermediate e "foo" - } - -_controllerA' :: MonadDep '[HasLogger, HasIntermediate] d e m => String -> m () -_controllerA' = \_ -> do e <- ask; liftD $ logger e "foo" ; liftD $ intermediate e "foo" - -_intermediate' :: MonadDep '[HasLogger] d e m => String -> m () -_intermediate' = \_ -> do e <- ask ; liftD $ logger e "foo" - --- --- -tests :: TestTree -tests = - testGroup - "All" - [ - testCase "undeceived" $ - assertEqual "" ["logger 1", "logger 1"] $ - execWriter $ (do e <- ask; _controllerA e 7) `runDepT` envW, - testCase "deceived" $ - assertEqual "" ["logger 2", "logger 1"] $ - execWriter $ (do e <- ask; _controllerB e 7) `runDepT` envW - ] - -main :: IO () -main = defaultMain tests +{-# 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 DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DerivingStrategies #-}++module Main (main) where++import Control.Monad.Dep+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Kind+import Data.Coerce+import Data.List (intercalate)+import Rank2 qualified+import Rank2.TH qualified+import Test.Tasty+import Test.Tasty.HUnit+import Prelude hiding (log)+import Data.SOP+import Data.SOP.NP++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++instance Monad m => Multicurryable '[] e m r (DepT e m r) where+ type DownToBaseMonad '[] e m r (DepT e m r) = m r+ multiuncurry action Nil = action+ multicurry f = f Nil+ _runFromEnv producer extractor = do+ e <- producer+ runDepT (extractor e) e++instance Multicurryable as e m r curried => Multicurryable (a ': as) e m r (a -> curried) where+ type DownToBaseMonad (a ': as) e m r (a -> curried) = a -> DownToBaseMonad as e m r curried+ multiuncurry f (I a :* as) = multiuncurry @as @e @m @r @curried (f a) as+ multicurry f a = multicurry @as @e @m @r @curried (f . (:*) (I a))+ _runFromEnv producer extractor a = _runFromEnv @as @e @m @r @curried producer (\f -> extractor f a)++class Multicurryable as e m r curried => Deceivable as newtyped e m r curried where+ type Deceive as newtyped e m r curried :: Type + deceive :: (e (DepT e m) -> newtyped) -> Deceive as newtyped e m r curried -> curried ++instance Monad m => Deceivable '[] newtyped e m r (DepT e m r) where+ type Deceive '[] newtyped e m r (DepT e m r) = ReaderT newtyped m r+ deceive f action = DepT (withReaderT f action)++instance Deceivable as newtyped e m r curried => Deceivable (a ': as) newtyped e m r (a -> curried) where+ type Deceive (a ': as) newtyped e m r (a -> curried) = a -> Deceive as newtyped e m r curried+ deceive f g a = deceive @as @newtyped @e @m @r f (g a)++--+--+--+type HasLogger :: (Type -> Type) -> Type -> Constraint+class HasLogger m em | em -> m where+ logger :: em -> String -> m ()+type HasIntermediate :: (Type -> Type) -> Type -> Constraint+class HasIntermediate m em | em -> m where+ intermediate :: em -> String -> m ()+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++envW :: Env (DepT Env (Writer [String]))+envW = Env + {+ _logger1 = + \_ -> tell ["logger 1"],+ _logger2 = + \_ -> tell ["logger 2"],+ _intermediate =+ \_ -> do e <- ask ; liftD $ logger e "foo", + _controllerA = + \_ -> do e <- ask; liftD $ logger e "foo" ; liftD $ intermediate e "foo",+ _controllerB = + deceive Switcheroo $+ \_ -> do e <- ask; liftD $ logger e "foo" ; liftD $ intermediate e "foo"+ }++_controllerA' :: MonadDep '[HasLogger, HasIntermediate] d e m => String -> m () +_controllerA' = \_ -> do e <- ask; liftD $ logger e "foo" ; liftD $ intermediate e "foo"++_intermediate' :: MonadDep '[HasLogger] d e m => String -> m () +_intermediate' = \_ -> do e <- ask ; liftD $ logger e "foo" ++--+--+tests :: TestTree+tests =+ testGroup+ "All"+ [+ testCase "undeceived" $+ assertEqual "" ["logger 1", "logger 1"] $+ execWriter $ (do e <- ask; _controllerA e 7) `runDepT` envW,+ testCase "deceived" $+ assertEqual "" ["logger 2", "logger 1"] $+ execWriter $ (do e <- ask; _controllerB e 7) `runDepT` envW+ ]++main :: IO ()+main = defaultMain tests
test/tests_env.hs view
@@ -1,230 +1,230 @@-{-# 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 StandaloneDeriving #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE ApplicativeDo #-} - -module Main (main) where - -import Dep.Has -import Dep.Env -import Control.Monad.Dep.Class -import Control.Monad.Reader -import Data.Functor.Constant -import Data.Functor.Compose -import Data.Coerce -import Data.Kind -import Data.List (intercalate) -import GHC.Generics (Generic) -import Test.Tasty -import Test.Tasty.HUnit -import Prelude hiding (log) -import Data.Functor.Identity -import GHC.TypeLits -import Control.Monad.Trans.Cont -import Data.Aeson -import Data.Aeson.Types -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.IORef -import System.IO -import Control.Exception -import Control.Arrow (Kleisli (..)) -import Data.Text qualified as Text -import Data.Function ((&)) -import Data.Functor ((<&>), ($>)) -import Data.String - -type Logger :: (Type -> Type) -> Type -newtype Logger d = Logger { - info :: String -> d () - } - -data Repository d = Repository - { findById :: Int -> d (Maybe String) - , putById :: Int -> String -> d () - , insert :: String -> d Int - } - -data Controller d = Controller - { create :: d Int - , append :: Int -> String -> d Bool - , inspect :: Int -> d (Maybe String) - } - -type MessagePrefix = Text.Text - -data LoggerConfiguration = LoggerConfiguration { - messagePrefix :: MessagePrefix - } deriving stock (Show, Generic) - deriving anyclass FromJSON - -makeStdoutLogger :: MonadIO m => MessagePrefix -> env -> Logger m -makeStdoutLogger prefix _ = Logger (\msg -> liftIO (putStrLn (Text.unpack prefix ++ msg))) - -allocateMap :: ContT () IO (IORef (Map Int String)) -allocateMap = ContT $ bracket (newIORef Map.empty) pure - -makeInMemoryRepository - :: Has Logger IO env - => IORef (Map Int String) - -> env - -> Repository IO -makeInMemoryRepository ref (asCall -> call) = do - Repository { - findById = \key -> do - call info "I'm going to do a lookup in the map!" - theMap <- readIORef ref - pure (Map.lookup key theMap) - , putById = \key content -> do - theMap <- readIORef ref - writeIORef ref $ Map.insert key content theMap - , insert = \content -> do - call info "I'm going to insert in the map!" - theMap <- readIORef ref - let next = Map.size theMap - writeIORef ref $ Map.insert next content theMap - pure next - } - -makeController :: (Has Logger m env, Has Repository m env, Monad m) => env -> Controller m -makeController (asCall -> call) = Controller { - create = do - call info "Creating a new empty resource." - key <- call insert "" - pure key - , append = \key extra -> do - call info "Appending to a resource" - mresource <- call findById key - case mresource of - Nothing -> do - pure False - Just resource -> do - call putById key (resource ++ extra) - pure True - , inspect = \key -> do - call findById key - } - --- from Has-using to positional -makeControllerPositional :: Monad m => Logger m -> Repository m -> Controller m -makeControllerPositional a b = makeController $ addDep a $ addDep b $ emptyEnv - --- from positional to Has-using -makeController' :: (Has Logger m env, Has Repository m env, Monad m) => env -> Controller m -makeController' env = makeControllerPositional (dep env) (dep env) - --- from purely Has-using to MonadDep-using --- but this is very verbose. See 'component' in "Control.Monad.Dep.Advice" of package dep-t-advice --- for an alternative. -makeController'' :: MonadDep [Has Logger, Has Repository] d e m => Controller m -makeController'' = Controller { - create = useEnv \env -> create (makeController env) - , append = \a b -> useEnv \env -> append (makeController env) a b - , inspect = \a -> useEnv \env -> inspect (makeController env) a - } - --- -type EnvHKD :: (Type -> Type) -> (Type -> Type) -> Type -data EnvHKD h m = EnvHKD - { logger :: h (Logger m), - repository :: h (Repository m), - controller :: h (Controller m) - } deriving stock Generic - deriving anyclass (Phased, DemotableFieldNames, FieldsFindableByType) - -deriving via Autowired (EnvHKD Identity m) instance Autowireable r_ m (EnvHKD Identity m) => Has r_ m (EnvHKD Identity m) - --- deriving via Autowired (EnvHKD Identity m) instance Has Logger m (EnvHKD Identity m) --- deriving via Autowired (EnvHKD Identity m) instance Has Repository m (EnvHKD Identity m) --- deriving via Autowired (EnvHKD Identity m) instance Has Controller m (EnvHKD Identity m) - -type Configurator = Kleisli Parser Value - -parseConf :: FromJSON a => Configurator a -parseConf = Kleisli parseJSON - -type Allocator = ContT () IO - -type Phases env = Configurator `Compose` Allocator `Compose` Constructor env - -env :: EnvHKD (Phases (EnvHKD Identity IO)) IO -env = EnvHKD { - logger = - parseConf `bindPhase` \(LoggerConfiguration {messagePrefix}) -> - skipPhase @Allocator $ - constructor (makeStdoutLogger messagePrefix) - , repository = - skipPhase @Configurator $ - allocateMap `bindPhase` \ref -> - constructor (makeInMemoryRepository ref) - , controller = - skipPhase @Configurator $ - skipPhase @Allocator $ - constructor makeController -} - -testEnvConstruction :: Assertion -testEnvConstruction = do - let parseResult = eitherDecode' (fromString "{ \"logger\" : { \"messagePrefix\" : \"[foo]\" }, \"repository\" : null, \"controller\" : null }") - print parseResult - let Right value = parseResult - Kleisli (withObject "configuration" -> parser) = - pullPhase @(Kleisli Parser Object) - $ mapPhaseWithFieldNames - (\fieldName (Kleisli f) -> Kleisli \o -> explicitParseField f o (fromString fieldName)) - $ env - Right allocators = parseEither parser value - runContT (pullPhase @Allocator allocators) \constructors -> do - let (asCall -> call) = fixEnv constructors - resourceId <- call create - call append resourceId "foo" - call append resourceId "bar" - Just result <- call inspect resourceId - assertEqual "" "foobar" $ result - --- --- --- -tests :: TestTree -tests = - testGroup - "All" - [ - testCase "fieldNames" $ - let fieldNames :: EnvHKD (Constant String) IO - fieldNames = demoteFieldNames - in - assertEqual "" "logger repository controller" $ - let EnvHKD { logger = Constant loggerField - , repository = Constant repositoryField - , controller = Constant controllerField - } = fieldNames - in intercalate " " [loggerField, repositoryField, controllerField] - , testCase "environmentConstruction" testEnvConstruction - ] - -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 StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ApplicativeDo #-}++module Main (main) where++import Dep.Has+import Dep.Env+import Control.Monad.Dep.Class+import Control.Monad.Reader+import Data.Functor.Constant+import Data.Functor.Compose+import Data.Coerce+import Data.Kind+import Data.List (intercalate)+import GHC.Generics (Generic)+import Test.Tasty+import Test.Tasty.HUnit+import Prelude hiding (log)+import Data.Functor.Identity+import GHC.TypeLits+import Control.Monad.Trans.Cont+import Data.Aeson+import Data.Aeson.Types+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.IORef+import System.IO+import Control.Exception+import Control.Arrow (Kleisli (..))+import Data.Text qualified as Text+import Data.Function ((&))+import Data.Functor ((<&>), ($>))+import Data.String++type Logger :: (Type -> Type) -> Type+newtype Logger d = Logger {+ info :: String -> d ()+ }++data Repository d = Repository+ { findById :: Int -> d (Maybe String)+ , putById :: Int -> String -> d ()+ , insert :: String -> d Int+ }++data Controller d = Controller + { create :: d Int+ , append :: Int -> String -> d Bool + , inspect :: Int -> d (Maybe String)+ } ++type MessagePrefix = Text.Text++data LoggerConfiguration = LoggerConfiguration { + messagePrefix :: MessagePrefix+ } deriving stock (Show, Generic)+ deriving anyclass FromJSON++makeStdoutLogger :: MonadIO m => MessagePrefix -> env -> Logger m+makeStdoutLogger prefix _ = Logger (\msg -> liftIO (putStrLn (Text.unpack prefix ++ msg)))++allocateMap :: ContT () IO (IORef (Map Int String))+allocateMap = ContT $ bracket (newIORef Map.empty) pure++makeInMemoryRepository + :: Has Logger IO env + => IORef (Map Int String) + -> env + -> Repository IO+makeInMemoryRepository ref (asCall -> call) = do+ Repository {+ findById = \key -> do+ call info "I'm going to do a lookup in the map!"+ theMap <- readIORef ref+ pure (Map.lookup key theMap)+ , putById = \key content -> do+ theMap <- readIORef ref+ writeIORef ref $ Map.insert key content theMap + , insert = \content -> do + call info "I'm going to insert in the map!"+ theMap <- readIORef ref+ let next = Map.size theMap+ writeIORef ref $ Map.insert next content theMap + pure next+ }++makeController :: (Has Logger m env, Has Repository m env, Monad m) => env -> Controller m+makeController (asCall -> call) = Controller {+ create = do+ call info "Creating a new empty resource."+ key <- call insert ""+ pure key+ , append = \key extra -> do+ call info "Appending to a resource"+ mresource <- call findById key+ case mresource of+ Nothing -> do+ pure False+ Just resource -> do+ call putById key (resource ++ extra) + pure True+ , inspect = \key -> do+ call findById key + }++-- from Has-using to positional+makeControllerPositional :: Monad m => Logger m -> Repository m -> Controller m+makeControllerPositional a b = makeController $ addDep a $ addDep b $ emptyEnv++-- from positional to Has-using+makeController' :: (Has Logger m env, Has Repository m env, Monad m) => env -> Controller m+makeController' env = makeControllerPositional (dep env) (dep env)++-- from purely Has-using to MonadDep-using+-- but this is very verbose. See 'component' in "Control.Monad.Dep.Advice" of package dep-t-advice+-- for an alternative.+makeController'' :: MonadDep [Has Logger, Has Repository] d e m => Controller m+makeController'' = Controller {+ create = useEnv \env -> create (makeController env)+ , append = \a b -> useEnv \env -> append (makeController env) a b + , inspect = \a -> useEnv \env -> inspect (makeController env) a + }++--+type EnvHKD :: (Type -> Type) -> (Type -> Type) -> Type+data EnvHKD h m = EnvHKD+ { logger :: h (Logger m),+ repository :: h (Repository m),+ controller :: h (Controller m)+ } deriving stock Generic+ deriving anyclass (Phased, DemotableFieldNames, FieldsFindableByType)++deriving via Autowired (EnvHKD Identity m) instance Autowireable r_ m (EnvHKD Identity m) => Has r_ m (EnvHKD Identity m)++-- deriving via Autowired (EnvHKD Identity m) instance Has Logger m (EnvHKD Identity m)+-- deriving via Autowired (EnvHKD Identity m) instance Has Repository m (EnvHKD Identity m)+-- deriving via Autowired (EnvHKD Identity m) instance Has Controller m (EnvHKD Identity m)++type Configurator = Kleisli Parser Value ++parseConf :: FromJSON a => Configurator a+parseConf = Kleisli parseJSON++type Allocator = ContT () IO++type Phases env = Configurator `Compose` Allocator `Compose` Constructor env++env :: EnvHKD (Phases (EnvHKD Identity IO)) IO+env = EnvHKD {+ logger = + parseConf `bindPhase` \(LoggerConfiguration {messagePrefix}) -> + skipPhase @Allocator $+ constructor (makeStdoutLogger messagePrefix)+ , repository = + skipPhase @Configurator $+ allocateMap `bindPhase` \ref -> + constructor (makeInMemoryRepository ref)+ , controller = + skipPhase @Configurator $+ skipPhase @Allocator $ + constructor makeController+}++testEnvConstruction :: Assertion+testEnvConstruction = do+ let parseResult = eitherDecode' (fromString "{ \"logger\" : { \"messagePrefix\" : \"[foo]\" }, \"repository\" : null, \"controller\" : null }")+ print parseResult + let Right value = parseResult + Kleisli (withObject "configuration" -> parser) = + pullPhase @(Kleisli Parser Object) + $ mapPhaseWithFieldNames + (\fieldName (Kleisli f) -> Kleisli \o -> explicitParseField f o (fromString fieldName)) + $ env+ Right allocators = parseEither parser value + runContT (pullPhase @Allocator allocators) \constructors -> do+ let (asCall -> call) = fixEnv constructors+ resourceId <- call create+ call append resourceId "foo"+ call append resourceId "bar"+ Just result <- call inspect resourceId+ assertEqual "" "foobar" $ result++--+--+--+tests :: TestTree+tests =+ testGroup+ "All"+ [+ testCase "fieldNames" $+ let fieldNames :: EnvHKD (Constant String) IO+ fieldNames = demoteFieldNames+ in+ assertEqual "" "logger repository controller" $+ let EnvHKD { logger = Constant loggerField+ , repository = Constant repositoryField + , controller = Constant controllerField + } = fieldNames+ in intercalate " " [loggerField, repositoryField, controllerField]+ , testCase "environmentConstruction" testEnvConstruction+ ]++main :: IO ()+main = defaultMain tests
test/tests_has.hs view
@@ -1,382 +1,382 @@-{-# 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 StandaloneDeriving #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveAnyClass #-} - -module Main (main) where - -import Dep.Has -import Dep.Env -import Control.Monad.Dep -import Control.Monad.Dep.Class -import Control.Monad.Reader -import Control.Monad.Writer -import Data.Coerce -import Data.Kind -import Data.List (intercalate) -import Data.SOP hiding (Compose) -import GHC.Generics -import Rank2 qualified -import Rank2.TH qualified -import Test.Tasty -import Test.Tasty.HUnit -import Prelude hiding (log) -import Data.Functor.Identity -import Data.Functor.Product -import GHC.TypeLits -import Barbies -import Control.Monad.Trans.Cont -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.IORef -import Data.Functor.Compose -import Control.Exception hiding (TypeError) -import System.IO -import Dep.Tagged -import Data.Function - --- https://stackoverflow.com/questions/53498707/cant-derive-generic-for-this-type/53499091#53499091 --- There are indeed some higher kinded types for which GHC can currently derive Generic1 instances, but the feature is so limited it's hardly worth mentioning. This is mostly an artifact of taking the original implementation of Generic1 intended for * -> * (which already has serious limitations), turning on PolyKinds, and keeping whatever sticks, which is not much. -type Logger :: (Type -> Type) -> Type -newtype Logger d = Logger {log :: String -> d ()} deriving stock Generic - -instance Dep Logger where - type DefaultFieldName Logger = "logger" - -data Repository d = Repository - { select :: String -> d [Int], - insert :: [Int] -> d () - } - deriving (Generic) - -instance Dep Repository where - type DefaultFieldName Repository = "repository" - -newtype Controller d = Controller {serve :: Int -> d String} deriving stock Generic - -instance Dep Controller where - type DefaultFieldName Controller = "controller" - -type Env :: (Type -> Type) -> Type -data Env m = Env - { logger :: Logger m, - repository :: Repository m, - controller :: Controller m - } - -instance Has Logger m (Env m) -instance Has Repository m (Env m) -instance Has Controller m (Env m) - -makeController :: forall d e m. MonadDep [Has Logger, Has Repository] d e m => Controller m -makeController = - Controller \url -> - useEnv \(asCall -> call) -> do - call log "I'm going to insert in the db!" - call select "select * from ..." - call insert [1, 2, 3, 4] - return "view" - -makeController2Loggers :: forall d e m. MonadDep [Has Logger, Has (Tagged "secondary" Logger), Has Repository] d e m => Controller m -makeController2Loggers = - Controller \url -> - useEnv \(asCall -> call) -> do - call log "I'm going to insert in the db!" - call select "select * from ..." - call insert [1, 2, 3, 4] - call (log . untag @"secondary") "Logged again from secondary logger." - return "view" - --- also toss in this helper function --- useEnv :: forall d e m r. (LiftDep d m, MonadReader e m) => (e -> d r) -> m r --- useEnv f = do --- e <- ask --- liftD (f e) - --- better than with all that liftD spam... although slightly less flexible -makeController' :: forall d e m. MonadDep [Has Logger, Has Repository] d e m => Controller m -makeController' = - Controller \url -> - useEnv \e -> do - let (asCall -> call) = e - call @Logger log "I'm going to insert in the db!" - call @Repository select "select * from ..." - call insert [5, 3, 43] - return "view" - -type EnvIO :: Type -data EnvIO = EnvIO - { logger :: Logger IO, - repository :: Repository IO - } - -instance Has Logger IO EnvIO - -instance Has Repository IO EnvIO - -type TestTrace = ([String], [Int]) - -makeFakeLogger :: MonadWriter TestTrace m => Logger m -makeFakeLogger = Logger \msg -> tell ([msg], []) - -makeFakeRepository :: (MonadDep '[Has Logger] d e m, MonadWriter TestTrace m) => Repository m -makeFakeRepository = - Repository - { select = \_ -> do - e <- ask - liftD $ log (dep e) "I'm going to select an entity" - return [], - insert = \entity -> do - (asCall -> call) <- ask - liftD $ call log "I'm going to write the entity!" - tell ([], entity) - } - -env :: Env (DepT Env (Writer TestTrace)) -env = - let logger = makeFakeLogger - repository = makeFakeRepository - controller = makeController - in Env {logger, repository, controller} - --- --- to test the coercible in the definition of Has -type EnvHKD :: (Type -> Type) -> (Type -> Type) -> Type -data EnvHKD h m = EnvHKD - { logger :: h (Logger m), - repository :: h (Repository m), - controller :: h (Controller m) - } - deriving stock Generic - deriving anyclass (Phased) - -instance Has Logger m (EnvHKD I m) -instance Has Repository m (EnvHKD I m) -instance Has Controller m (EnvHKD I m) - --- --- Test TheDefaultFieldName -type EnvHKD' :: (Type -> Type) -> (Type -> Type) -> Type -data EnvHKD' h m = EnvHKD' - { logger :: h (Logger m), - repository :: h (Repository m), - controller :: h (Controller m) - } - -deriving via (TheDefaultFieldName (EnvHKD' I m)) instance Has Logger m (EnvHKD' I m) -deriving via (TheDefaultFieldName (EnvHKD' I m)) instance Has Repository m (EnvHKD' I m) -deriving via (TheDefaultFieldName (EnvHKD' I m)) instance Has Controller m (EnvHKD' I m) - ---- Test isolated instance definitions for autowired -type EnvHKD2 :: (Type -> Type) -> (Type -> Type) -> Type -data EnvHKD2 h m = EnvHKD2 - { logger :: h (Logger m), - repository :: h (Repository m), - controller :: h (Controller m) - } deriving stock Generic - deriving anyclass FieldsFindableByType - -deriving via (Autowired (EnvHKD2 Identity m)) instance Has Logger m (EnvHKD2 Identity m) -deriving via (Autowired (EnvHKD2 Identity m)) instance Has Repository m (EnvHKD2 Identity m) -deriving via (Autowired (EnvHKD2 Identity m)) instance Has Controller m (EnvHKD2 Identity m) - --- findLogger2 :: EnvHKD2 Identity m -> Logger m --- findLogger2 env = dep env - -type EnvHKD3 :: (Type -> Type) -> (Type -> Type) -> Type -data EnvHKD3 h m = EnvHKD3 - { logger :: h (Logger m), - repository :: h (Repository m), - controller :: h (Controller m) - } deriving stock Generic - deriving anyclass FieldsFindableByType - -deriving via Autowired (EnvHKD3 Identity m) instance Autowireable r_ m (EnvHKD3 Identity m) => Has r_ m (EnvHKD3 Identity m) - -findLogger3 :: EnvHKD3 Identity m -> Logger m -findLogger3 env = dep env - - - -type EnvHKD4 :: (Type -> Type) -> (Type -> Type) -> Type -data EnvHKD4 h m = EnvHKD4 - { loggerx :: h (Logger m), - repositoryx :: h (Repository m), - controllerx :: h (Controller m) - } deriving (Generic) - -type Correspondence4 :: Type -> Symbol -type family Correspondence4 r :: Symbol where - Correspondence4 (Logger m) = "loggerx" - -- Correspondence4 (Identity (Logger m)) = "logger" - Correspondence4 (Repository m) = "repositoryx" - Correspondence4 (Controller m) = "controllerx" - Correspondence4 _ = TypeError (Text "what") - --- non-default FieldsFindableByType instance -instance FieldsFindableByType (EnvHKD4 Identity m) where - type FindFieldByType (EnvHKD4 Identity m) r = Correspondence4 r - -deriving via Autowired (EnvHKD4 Identity m) instance Autowireable r_ m (EnvHKD4 Identity m) => Has r_ m (EnvHKD4 Identity m) - -findLogger4 :: EnvHKD4 Identity m -> Logger m -findLogger4 env = dep env -findRepository4 :: EnvHKD4 Identity m -> Repository m -findRepository4 env = dep env -findController4 :: EnvHKD4 Identity m -> Controller m -findController4 env = dep env - -type EnvHKD5 :: (Type -> Type) -> Type -data EnvHKD5 m = EnvHKD5 - { loggerx :: Logger m, - repositoryx :: Repository m, - controllerx :: Controller m - } deriving stock Generic - deriving anyclass FieldsFindableByType - -deriving via Autowired (EnvHKD5 m) instance Has Logger m (EnvHKD5 m) -deriving via Autowired (EnvHKD5 m) instance Has Repository m (EnvHKD5 m) -deriving via Autowired (EnvHKD5 m) instance Has Controller m (EnvHKD5 m) - -findLogger5 :: EnvHKD5 m -> Logger m -findLogger5 env = dep env -findRepository5 :: EnvHKD5 m -> Repository m -findRepository5 env = dep env -findController5 :: EnvHKD5 m -> Controller m -findController5 env = dep env - --- Test TheFieldName -type EnvHKD6 :: (Type -> Type) -> Type -data EnvHKD6 m = EnvHKD6 - { loggerx :: (Logger m), - repositoryx :: (Repository m), - controllerx :: (Controller m) - } deriving stock Generic - -deriving via (TheFieldName "loggerx" (EnvHKD6 m)) instance Has Logger m (EnvHKD6 m) -deriving via (TheFieldName "repositoryx" (EnvHKD6 m)) instance Has Repository m (EnvHKD6 m) -deriving via (TheFieldName "controllerx" (EnvHKD6 m)) instance Has Controller m (EnvHKD6 m) - -findLogger6 :: EnvHKD6 m -> Logger m -findLogger6 env = dep env -findRepository6 :: EnvHKD6 m -> Repository m -findRepository6 env = dep env -findController6 :: EnvHKD6 m -> Controller m -findController6 env = dep env - - --- Deriving Phased using the barbies library, to check that they are compatible --- typeclasses - --- newtype B e_ h m = B (e_ h m) - --- instance (FunctorT e_, TraversableT e_, ApplicativeT e_) => Phased (B e_) where --- traverseH f (B e) = B <$> ttraverse f e --- liftA2H f (B ax) (B hx) = B $ tmap (\(Pair az hz) -> f az hz) $ tprod ax hx - -type EnvHKD7 :: (Type -> Type) -> (Type -> Type) -> Type -data EnvHKD7 h m = EnvHKD7 - { logger :: h (Logger m), - repository :: h (Repository m), - controller :: h (Controller m) - } deriving stock Generic - deriving anyclass (FunctorT, TraversableT, ApplicativeT) - -instance Phased EnvHKD7 where - traverseH f e = ttraverse f e - liftA2H f ax hx = tmap (\(Pair az hz) -> f az hz) $ tprod ax hx - - --- This is an example of how to combine the "Phased" approach --- with DepT. --- --- Notice that the "allocator" works in IO but the ultimate --- effect monad is a Writer. --- --- Also the identity monad is I instead of Identity, --- code works with both. -type Allocator = ContT () IO - -type Phases = Allocator `Compose` I - -allocateMap :: ContT () IO (IORef (Map Int String)) -allocateMap = ContT $ bracket (newIORef Map.empty) pure - -envHKD :: EnvHKD Phases (DepT (EnvHKD I) (Writer TestTrace)) -envHKD = EnvHKD { - logger = - skipPhase @Allocator $ - pure $ makeFakeLogger - , repository = - allocateMap `bindPhase` \_ -> - pure $ makeFakeRepository - , controller = - skipPhase @Allocator $ - pure $ makeController - } - -testEnvHKD :: Assertion -testEnvHKD = do - runContT (pullPhase @Allocator envHKD) \env -> do - let r = execWriter $ runDepT (do env <- ask; serve (dep env) 7) env - assertEqual "" (["I'm going to insert in the db!","I'm going to select an entity","I'm going to write the entity!"],[1,2,3,4]) r - --- --- Phased Approach + DepT, with an InductiveEnv --- InductiveEnv requires Identity as the final wrapping type, I doesn't work :( - -testEnvInductive :: Assertion -testEnvInductive = do - let envInductive = - EmptyEnv - & AddDep (skipPhase @Allocator $ - Identity $ makeFakeLogger) - & AddDep (skipPhase @Allocator $ - Identity $ tagged @"secondary" makeFakeLogger) - & AddDep (allocateMap `bindPhase` \_ -> - Identity $ makeFakeRepository) - & AddDep (skipPhase @Allocator $ - Identity $ makeController2Loggers) - runContT (pullPhase @Allocator envInductive) \env -> do - let r = execWriter $ runDepT (do env <- ask; serve (dep env) 7) env - assertEqual "" (["I'm going to insert in the db!","I'm going to select an entity","I'm going to write the entity!", "Logged again from secondary logger."],[1,2,3,4]) r - --- --- --- -tests :: TestTree -tests = - testGroup - "All" - [ - testCase "non HKD, pure" $ - assertEqual "" (["I'm going to insert in the db!","I'm going to select an entity","I'm going to write the entity!"],[1,2,3,4]) $ - execWriter $ runDepT (do env <- ask; serve (dep env) 7) env - , testCase "HKD, phased, uses I, pure" $ testEnvHKD - , testCase "HKD, InductiveEnv, uses Identity" $ testEnvInductive - ] - -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 StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveAnyClass #-}++module Main (main) where++import Dep.Has+import Dep.Env+import Control.Monad.Dep+import Control.Monad.Dep.Class+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Coerce+import Data.Kind+import Data.List (intercalate)+import Data.SOP hiding (Compose)+import GHC.Generics+import Rank2 qualified+import Rank2.TH qualified+import Test.Tasty+import Test.Tasty.HUnit+import Prelude hiding (log)+import Data.Functor.Identity+import Data.Functor.Product+import GHC.TypeLits+import Barbies+import Control.Monad.Trans.Cont+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.IORef+import Data.Functor.Compose+import Control.Exception hiding (TypeError)+import System.IO+import Dep.Tagged+import Data.Function++-- https://stackoverflow.com/questions/53498707/cant-derive-generic-for-this-type/53499091#53499091+-- There are indeed some higher kinded types for which GHC can currently derive Generic1 instances, but the feature is so limited it's hardly worth mentioning. This is mostly an artifact of taking the original implementation of Generic1 intended for * -> * (which already has serious limitations), turning on PolyKinds, and keeping whatever sticks, which is not much.+type Logger :: (Type -> Type) -> Type+newtype Logger d = Logger {log :: String -> d ()} deriving stock Generic++instance Dep Logger where+ type DefaultFieldName Logger = "logger"++data Repository d = Repository+ { select :: String -> d [Int],+ insert :: [Int] -> d ()+ }+ deriving (Generic)++instance Dep Repository where+ type DefaultFieldName Repository = "repository"++newtype Controller d = Controller {serve :: Int -> d String} deriving stock Generic++instance Dep Controller where+ type DefaultFieldName Controller = "controller"++type Env :: (Type -> Type) -> Type+data Env m = Env+ { logger :: Logger m,+ repository :: Repository m,+ controller :: Controller m+ }++instance Has Logger m (Env m)+instance Has Repository m (Env m)+instance Has Controller m (Env m)++makeController :: forall d e m. MonadDep [Has Logger, Has Repository] d e m => Controller m+makeController =+ Controller \url -> + useEnv \(asCall -> call) -> do+ call log "I'm going to insert in the db!"+ call select "select * from ..."+ call insert [1, 2, 3, 4]+ return "view"++makeController2Loggers :: forall d e m. MonadDep [Has Logger, Has (Tagged "secondary" Logger), Has Repository] d e m => Controller m+makeController2Loggers =+ Controller \url -> + useEnv \(asCall -> call) -> do+ call log "I'm going to insert in the db!"+ call select "select * from ..."+ call insert [1, 2, 3, 4]+ call (log . untag @"secondary") "Logged again from secondary logger."+ return "view"++-- also toss in this helper function+-- useEnv :: forall d e m r. (LiftDep d m, MonadReader e m) => (e -> d r) -> m r+-- useEnv f = do+-- e <- ask+-- liftD (f e)++-- better than with all that liftD spam... although slightly less flexible+makeController' :: forall d e m. MonadDep [Has Logger, Has Repository] d e m => Controller m+makeController' =+ Controller \url ->+ useEnv \e -> do+ let (asCall -> call) = e+ call @Logger log "I'm going to insert in the db!"+ call @Repository select "select * from ..."+ call insert [5, 3, 43]+ return "view"++type EnvIO :: Type+data EnvIO = EnvIO+ { logger :: Logger IO,+ repository :: Repository IO+ }++instance Has Logger IO EnvIO++instance Has Repository IO EnvIO++type TestTrace = ([String], [Int])++makeFakeLogger :: MonadWriter TestTrace m => Logger m+makeFakeLogger = Logger \msg -> tell ([msg], [])++makeFakeRepository :: (MonadDep '[Has Logger] d e m, MonadWriter TestTrace m) => Repository m+makeFakeRepository =+ Repository+ { select = \_ -> do+ e <- ask+ liftD $ log (dep e) "I'm going to select an entity"+ return [],+ insert = \entity -> do+ (asCall -> call) <- ask+ liftD $ call log "I'm going to write the entity!"+ tell ([], entity)+ }++env :: Env (DepT Env (Writer TestTrace))+env =+ let logger = makeFakeLogger+ repository = makeFakeRepository+ controller = makeController+ in Env {logger, repository, controller}++--+-- to test the coercible in the definition of Has+type EnvHKD :: (Type -> Type) -> (Type -> Type) -> Type+data EnvHKD h m = EnvHKD+ { logger :: h (Logger m),+ repository :: h (Repository m),+ controller :: h (Controller m)+ }+ deriving stock Generic+ deriving anyclass (Phased)++instance Has Logger m (EnvHKD I m)+instance Has Repository m (EnvHKD I m)+instance Has Controller m (EnvHKD I m)++--+-- Test TheDefaultFieldName+type EnvHKD' :: (Type -> Type) -> (Type -> Type) -> Type+data EnvHKD' h m = EnvHKD'+ { logger :: h (Logger m),+ repository :: h (Repository m),+ controller :: h (Controller m)+ }++deriving via (TheDefaultFieldName (EnvHKD' I m)) instance Has Logger m (EnvHKD' I m)+deriving via (TheDefaultFieldName (EnvHKD' I m)) instance Has Repository m (EnvHKD' I m)+deriving via (TheDefaultFieldName (EnvHKD' I m)) instance Has Controller m (EnvHKD' I m)++--- Test isolated instance definitions for autowired+type EnvHKD2 :: (Type -> Type) -> (Type -> Type) -> Type+data EnvHKD2 h m = EnvHKD2+ { logger :: h (Logger m),+ repository :: h (Repository m),+ controller :: h (Controller m)+ } deriving stock Generic+ deriving anyclass FieldsFindableByType ++deriving via (Autowired (EnvHKD2 Identity m)) instance Has Logger m (EnvHKD2 Identity m)+deriving via (Autowired (EnvHKD2 Identity m)) instance Has Repository m (EnvHKD2 Identity m)+deriving via (Autowired (EnvHKD2 Identity m)) instance Has Controller m (EnvHKD2 Identity m)++-- findLogger2 :: EnvHKD2 Identity m -> Logger m+-- findLogger2 env = dep env++type EnvHKD3 :: (Type -> Type) -> (Type -> Type) -> Type+data EnvHKD3 h m = EnvHKD3+ { logger :: h (Logger m),+ repository :: h (Repository m),+ controller :: h (Controller m)+ } deriving stock Generic+ deriving anyclass FieldsFindableByType+ +deriving via Autowired (EnvHKD3 Identity m) instance Autowireable r_ m (EnvHKD3 Identity m) => Has r_ m (EnvHKD3 Identity m)++findLogger3 :: EnvHKD3 Identity m -> Logger m+findLogger3 env = dep env++++type EnvHKD4 :: (Type -> Type) -> (Type -> Type) -> Type+data EnvHKD4 h m = EnvHKD4+ { loggerx :: h (Logger m),+ repositoryx :: h (Repository m),+ controllerx :: h (Controller m)+ } deriving (Generic)+ +type Correspondence4 :: Type -> Symbol+type family Correspondence4 r :: Symbol where+ Correspondence4 (Logger m) = "loggerx"+ -- Correspondence4 (Identity (Logger m)) = "logger"+ Correspondence4 (Repository m) = "repositoryx"+ Correspondence4 (Controller m) = "controllerx"+ Correspondence4 _ = TypeError (Text "what")++-- non-default FieldsFindableByType instance+instance FieldsFindableByType (EnvHKD4 Identity m) where+ type FindFieldByType (EnvHKD4 Identity m) r = Correspondence4 r++deriving via Autowired (EnvHKD4 Identity m) instance Autowireable r_ m (EnvHKD4 Identity m) => Has r_ m (EnvHKD4 Identity m)++findLogger4 :: EnvHKD4 Identity m -> Logger m+findLogger4 env = dep env+findRepository4 :: EnvHKD4 Identity m -> Repository m+findRepository4 env = dep env+findController4 :: EnvHKD4 Identity m -> Controller m+findController4 env = dep env++type EnvHKD5 :: (Type -> Type) -> Type+data EnvHKD5 m = EnvHKD5+ { loggerx :: Logger m,+ repositoryx :: Repository m,+ controllerx :: Controller m+ } deriving stock Generic+ deriving anyclass FieldsFindableByType ++deriving via Autowired (EnvHKD5 m) instance Has Logger m (EnvHKD5 m)+deriving via Autowired (EnvHKD5 m) instance Has Repository m (EnvHKD5 m)+deriving via Autowired (EnvHKD5 m) instance Has Controller m (EnvHKD5 m)++findLogger5 :: EnvHKD5 m -> Logger m+findLogger5 env = dep env+findRepository5 :: EnvHKD5 m -> Repository m+findRepository5 env = dep env+findController5 :: EnvHKD5 m -> Controller m+findController5 env = dep env++-- Test TheFieldName+type EnvHKD6 :: (Type -> Type) -> Type+data EnvHKD6 m = EnvHKD6+ { loggerx :: (Logger m),+ repositoryx :: (Repository m),+ controllerx :: (Controller m)+ } deriving stock Generic+ +deriving via (TheFieldName "loggerx" (EnvHKD6 m)) instance Has Logger m (EnvHKD6 m)+deriving via (TheFieldName "repositoryx" (EnvHKD6 m)) instance Has Repository m (EnvHKD6 m)+deriving via (TheFieldName "controllerx" (EnvHKD6 m)) instance Has Controller m (EnvHKD6 m)++findLogger6 :: EnvHKD6 m -> Logger m+findLogger6 env = dep env+findRepository6 :: EnvHKD6 m -> Repository m+findRepository6 env = dep env+findController6 :: EnvHKD6 m -> Controller m+findController6 env = dep env+++-- Deriving Phased using the barbies library, to check that they are compatible+-- typeclasses++-- newtype B e_ h m = B (e_ h m)++-- instance (FunctorT e_, TraversableT e_, ApplicativeT e_) => Phased (B e_) where+-- traverseH f (B e) = B <$> ttraverse f e+-- liftA2H f (B ax) (B hx) = B $ tmap (\(Pair az hz) -> f az hz) $ tprod ax hx++type EnvHKD7 :: (Type -> Type) -> (Type -> Type) -> Type+data EnvHKD7 h m = EnvHKD7+ { logger :: h (Logger m),+ repository :: h (Repository m),+ controller :: h (Controller m)+ } deriving stock Generic+ deriving anyclass (FunctorT, TraversableT, ApplicativeT)++instance Phased EnvHKD7 where+ traverseH f e = ttraverse f e+ liftA2H f ax hx = tmap (\(Pair az hz) -> f az hz) $ tprod ax hx+++-- This is an example of how to combine the "Phased" approach +-- with DepT.+--+-- Notice that the "allocator" works in IO but the ultimate+-- effect monad is a Writer.+--+-- Also the identity monad is I instead of Identity, +-- code works with both.+type Allocator = ContT () IO++type Phases = Allocator `Compose` I++allocateMap :: ContT () IO (IORef (Map Int String))+allocateMap = ContT $ bracket (newIORef Map.empty) pure++envHKD :: EnvHKD Phases (DepT (EnvHKD I) (Writer TestTrace))+envHKD = EnvHKD {+ logger = + skipPhase @Allocator $+ pure $ makeFakeLogger+ , repository = + allocateMap `bindPhase` \_ -> + pure $ makeFakeRepository+ , controller = + skipPhase @Allocator $ + pure $ makeController+ } ++testEnvHKD :: Assertion+testEnvHKD = do+ runContT (pullPhase @Allocator envHKD) \env -> do+ let r = execWriter $ runDepT (do env <- ask; serve (dep env) 7) env+ assertEqual "" (["I'm going to insert in the db!","I'm going to select an entity","I'm going to write the entity!"],[1,2,3,4]) r++--+-- Phased Approach + DepT, with an InductiveEnv+-- InductiveEnv requires Identity as the final wrapping type, I doesn't work :(++testEnvInductive :: Assertion+testEnvInductive = do+ let envInductive =+ EmptyEnv + & AddDep (skipPhase @Allocator $+ Identity $ makeFakeLogger) + & AddDep (skipPhase @Allocator $+ Identity $ tagged @"secondary" makeFakeLogger) + & AddDep (allocateMap `bindPhase` \_ -> + Identity $ makeFakeRepository)+ & AddDep (skipPhase @Allocator $ + Identity $ makeController2Loggers)+ runContT (pullPhase @Allocator envInductive) \env -> do+ let r = execWriter $ runDepT (do env <- ask; serve (dep env) 7) env+ assertEqual "" (["I'm going to insert in the db!","I'm going to select an entity","I'm going to write the entity!", "Logged again from secondary logger."],[1,2,3,4]) r++--+--+--+tests :: TestTree+tests =+ testGroup+ "All"+ [+ testCase "non HKD, pure" $+ assertEqual "" (["I'm going to insert in the db!","I'm going to select an entity","I'm going to write the entity!"],[1,2,3,4]) $+ execWriter $ runDepT (do env <- ask; serve (dep env) 7) env+ , testCase "HKD, phased, uses I, pure" $ testEnvHKD+ , testCase "HKD, InductiveEnv, uses Identity" $ testEnvInductive+ ]++main :: IO ()+main = defaultMain tests