diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,14 @@ -# Revision history for dep-t-dynamic - -## 0.1.0.2 - -* `fromBare` and `toBare` moved to dep-t and re-exported from there. - -## 0.1.0.1 - -* Works with algebraic-graphs 0.6. +# Revision history for dep-t-dynamic + +## 0.1.1.0 + +* Small tweak for compatibility with the "extra Typeable constraint" change in + dep-t 0.6.4.0. + +## 0.1.0.2 + +* `fromBare` and `toBare` moved to dep-t and re-exported from there. + +## 0.1.0.1 + +* Works with algebraic-graphs 0.6. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,60 +1,60 @@ -# dep-t-dynamic - -This library is a compation to [dep-t](https://hackage.haskell.org/package/dep-t) and in particular it complements the [`Dep.Env`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Env.html) module. It provides various types of dependency injection environments that are dynamically typed to some degree: missing dependencies are not detected at compilation time. Static checks are sacrificed for advantages like faster compilation. - -[![dep-t-dynamic.png](https://i.postimg.cc/DyP2zxcf/dep-t-dynamic.png)](https://postimg.cc/9rz38tSs) - -- **Dep.Dynamic** is the simplest dynamic environment, but it doesn't give many guarantees. -- **Dep.Checked** and **Dep.SimpleChecked** give greater guarantees at the cost of more ceremony and explicitness. **Dep.Checked** can only be used with the [`DepT`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Control-Monad-Dep.html) monad. - -## Rationale - -In [dep-t](https://hackage.haskell.org/package/dep-t), functions list their dependences on "injectable" components by means of [`Has`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Has.html) constraints. One step when creating your application is defining a big environment record whose fields are the components, and giving it suitable `Has` instances. - -Environments often have [two type parameters](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Env.html#g:6): - -- One is an `Applicative` "phase" that wraps each field and describes how far along we are in the process of constructing the environment (the `Identity` function correspond to a "finished" environment, ready to be used). -- The other is the effect monad which parameterizes each component in the environment. - -Usually environments will be vanilla Haskell records. It has the advantage that "missing" dependencies are caught at compile-time. But using records might be undesirable is some cases: - -- For environments with a big number of components, compiling the environment type might be slow. -- Defining the required `Has` instances for the environment might be a chore, even with the helpers from [`Dep.Env`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Env.html#g:2). - -### How `Dep.Dynamic` helps - -`DynamicEnv` from `Dep.Dynamic` allows registering any component at runtime. -Because there aren't static fields to check, compilation is faster. - -`DynamicEnv` also has a [`Has`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Has.html#t:Has) instance for *any* component! However, if the component hasn't been previously registered, [`dep`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Has.html#v:dep) will throw an exception. - - -### Isn't that a wee bit too unsafe? - -Yeah, pretty much. It means that you can forget to add some seldomly-used -dependency and then have an exception pop up at an inconvenient time when that -dependency is first exercised. - -That's where `Dep.Checked` and `Dep.SimpleChecked` may help. - -### How can the `-Checked` modules help? - -They define wrappers around `DynamicEnv` that require you to list each component's dependencies as you add them to the environment. Then, before putting the environment to use, they let you check at runtime that the dependencies for all components are present in the environment. - -It's more verbose and explicit, but safer. It makes easy to check in a unit test that the environment has been set up correctly. - -As a side benefit, the `-Checked` modules give you the graph of dependencies as a value that you can analyze and [export](https://hackage.haskell.org/package/algebraic-graphs-0.5/docs/Algebra-Graph-Export-Dot.html) as a [DOT](https://en.wikipedia.org/wiki/DOT_(graph_description_language)) file. - -`Dep.Checked` can only be used when your dependencies live in the `DepT` monad. Use `Dep.SimpleChecked` otherwise. - -## Relationship with the "registry" package - -This library is heavily inspired in the [registry](https://hackage.haskell.org/package/registry) package, which provides a `Typeable`-based method for performing dependency injection. - -This library is more restrictive and less ergonomic in some aspects, but it fits better with how [dep-t](https://hackage.haskell.org/package/dep-t) works. - -Some notable differences with **registry**: - -- `Dep.Dynamic` only reports missing dependencies when the program logic first searches for them, while **registry** reports them when calling `withRegistry`. -- `Dep.Checked` and `Dep.SimpleChecked` do allow you to find missing dependencies before running the program logic, but they force you to explicitly list the dependencies of each new component you add to the environment, something that **registry** doesn't require. -- Unlike in **registry**, there are no specific [warmup](https://hackage.haskell.org/package/registry-0.2.1.0/docs/Data-Registry-Warmup.html#v:warmupOf) combinators. Allocating the resources required by a component must be done in an [`Applicative`](https://hackage.haskell.org/package/managed) "phase" of a [`Phased`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Env.html#t:Phased) environment. +# dep-t-dynamic + +This library is a compation to [dep-t](https://hackage.haskell.org/package/dep-t) and in particular it complements the [`Dep.Env`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Env.html) module. It provides various types of dependency injection environments that are dynamically typed to some degree: missing dependencies are not detected at compilation time. Static checks are sacrificed for advantages like faster compilation. + +[![dep-t-dynamic.png](https://i.postimg.cc/DyP2zxcf/dep-t-dynamic.png)](https://postimg.cc/9rz38tSs) + +- **Dep.Dynamic** is the simplest dynamic environment, but it doesn't give many guarantees. +- **Dep.Checked** and **Dep.SimpleChecked** give greater guarantees at the cost of more ceremony and explicitness. **Dep.Checked** can only be used with the [`DepT`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Control-Monad-Dep.html) monad. + +## Rationale + +In [dep-t](https://hackage.haskell.org/package/dep-t), functions list their dependences on "injectable" components by means of [`Has`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Has.html) constraints. One step when creating your application is defining a big environment record whose fields are the components, and giving it suitable `Has` instances. + +Environments often have [two type parameters](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Env.html#g:6): + +- One is an `Applicative` "phase" that wraps each field and describes how far along we are in the process of constructing the environment (the `Identity` function correspond to a "finished" environment, ready to be used). +- The other is the effect monad which parameterizes each component in the environment. + +Usually environments will be vanilla Haskell records. It has the advantage that "missing" dependencies are caught at compile-time. But using records might be undesirable is some cases: + +- For environments with a big number of components, compiling the environment type might be slow. +- Defining the required `Has` instances for the environment might be a chore, even with the helpers from [`Dep.Env`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Env.html#g:2). + +### How `Dep.Dynamic` helps + +`DynamicEnv` from `Dep.Dynamic` allows registering any component at runtime. +Because there aren't static fields to check, compilation is faster. + +`DynamicEnv` also has a [`Has`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Has.html#t:Has) instance for *any* component! However, if the component hasn't been previously registered, [`dep`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Has.html#v:dep) will throw an exception. + + +### Isn't that a wee bit too unsafe? + +Yeah, pretty much. It means that you can forget to add some seldomly-used +dependency and then have an exception pop up at an inconvenient time when that +dependency is first exercised. + +That's where `Dep.Checked` and `Dep.SimpleChecked` may help. + +### How can the `-Checked` modules help? + +They define wrappers around `DynamicEnv` that require you to list each component's dependencies as you add them to the environment. Then, before putting the environment to use, they let you check at runtime that the dependencies for all components are present in the environment. + +It's more verbose and explicit, but safer. It makes easy to check in a unit test that the environment has been set up correctly. + +As a side benefit, the `-Checked` modules give you the graph of dependencies as a value that you can analyze and [export](https://hackage.haskell.org/package/algebraic-graphs-0.5/docs/Algebra-Graph-Export-Dot.html) as a [DOT](https://en.wikipedia.org/wiki/DOT_(graph_description_language)) file. + +`Dep.Checked` can only be used when your dependencies live in the `DepT` monad. Use `Dep.SimpleChecked` otherwise. + +## Relationship with the "registry" package + +This library is heavily inspired in the [registry](https://hackage.haskell.org/package/registry) package, which provides a `Typeable`-based method for performing dependency injection. + +This library is more restrictive and less ergonomic in some aspects, but it fits better with how [dep-t](https://hackage.haskell.org/package/dep-t) works. + +Some notable differences with **registry**: + +- `Dep.Dynamic` only reports missing dependencies when the program logic first searches for them, while **registry** reports them when calling `withRegistry`. +- `Dep.Checked` and `Dep.SimpleChecked` do allow you to find missing dependencies before running the program logic, but they force you to explicitly list the dependencies of each new component you add to the environment, something that **registry** doesn't require. +- Unlike in **registry**, there are no specific [warmup](https://hackage.haskell.org/package/registry-0.2.1.0/docs/Data-Registry-Warmup.html#v:warmupOf) combinators. Allocating the resources required by a component must be done in an [`Applicative`](https://hackage.haskell.org/package/managed) "phase" of a [`Phased`](https://hackage.haskell.org/package/dep-t-0.6.0.0/docs/Dep-Env.html#t:Phased) environment. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/dep-t-dynamic.cabal b/dep-t-dynamic.cabal --- a/dep-t-dynamic.cabal +++ b/dep-t-dynamic.cabal @@ -1,102 +1,102 @@ -cabal-version: 3.0 - -name: dep-t-dynamic -version: 0.1.0.2 -synopsis: A dynamic environment for dependency injection. -description: This library is a companion to "dep-t". It provides "environments" - into which you - can register record values parameterized by a monad. - - The environments are dynamically typed in the sense that - the types of the contained records - are not reflected in - the type of the environment, and in that - searching for a - component record might fail at runtime if the record - hasn't been previously inserted. - - The main purpose of the library is to support dependency injection. --- 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-dynamic.git - -common common - build-depends: base >= 4.10.0.0 && < 5, - transformers >= 0.5.0.0, - dep-t ^>= 0.6.2.0, - unordered-containers >= 0.2.14, - hashable >= 1.0.1.1, - sop-core ^>= 0.5.0.0, - algebraic-graphs ^>= 0.6 - default-language: Haskell2010 - -library - import: common - exposed-modules: Dep.Checked - Dep.SimpleChecked - Dep.Dynamic - other-modules: Dep.Dynamic.Internal - hs-source-dirs: lib - -common common-tests - import: common - build-depends: - dep-t-advice, - dep-t, - dep-t-dynamic, - template-haskell, - text, - unliftio-core >= 0.2.0.0, - mtl >= 2.2, - -common common-tasty - import: common-tests - hs-source-dirs: test - build-depends: - tasty >= 1.3.1, - tasty-hunit >= 0.10.0.2, -test-suite tests - import: common-tasty - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: tests.hs - build-depends: - dep-t, - dep-t-dynamic, - template-haskell, - aeson ^>= 2.0, - bytestring, - text, - containers - -test-suite synthetic-callstack-tests - import: common-tasty - type: exitcode-stdio-1.0 - main-is: synthetic-callstack-tests.hs - build-depends: aeson, - containers, - unordered-containers >= 0.2.14, - microlens >= 0.4.12.0 - --- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288 --- http://hackage.haskell.org/package/cabal-doctest -test-suite doctests - import: common - ghc-options: -threaded - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: doctests.hs - build-depends: - dep-t, - dep-t-dynamic, - dep-t-advice, - doctest ^>= 0.20, - +cabal-version: 3.0 + +name: dep-t-dynamic +version: 0.1.1.0 +synopsis: A dynamic environment for dependency injection. +description: This library is a companion to "dep-t". It provides "environments" + into which you + can register record values parameterized by a monad. + + The environments are dynamically typed in the sense that + the types of the contained records + are not reflected in + the type of the environment, and in that + searching for a + component record might fail at runtime if the record + hasn't been previously inserted. + + The main purpose of the library is to support dependency injection. +-- 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-dynamic.git + +common common + build-depends: base >= 4.10.0.0 && < 5, + transformers >= 0.5.0.0, + dep-t >= 0.6.4.0 && < 0.7, + unordered-containers >= 0.2.14, + hashable >= 1.0.1.1, + sop-core ^>= 0.5.0.0, + algebraic-graphs ^>= 0.6 + default-language: Haskell2010 + +library + import: common + exposed-modules: Dep.Checked + Dep.SimpleChecked + Dep.Dynamic + other-modules: Dep.Dynamic.Internal + hs-source-dirs: lib + +common common-tests + import: common + build-depends: + dep-t-advice, + dep-t, + dep-t-dynamic, + template-haskell, + text, + unliftio-core >= 0.2.0.0, + mtl >= 2.2, + +common common-tasty + import: common-tests + hs-source-dirs: test + build-depends: + tasty >= 1.3.1, + tasty-hunit >= 0.10.0.2, +test-suite tests + import: common-tasty + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: tests.hs + build-depends: + dep-t, + dep-t-dynamic, + template-haskell, + aeson ^>= 2.0, + bytestring, + text, + containers + +test-suite synthetic-callstack-tests + import: common-tasty + type: exitcode-stdio-1.0 + main-is: synthetic-callstack-tests.hs + build-depends: aeson, + containers, + unordered-containers >= 0.2.14, + microlens >= 0.4.12.0 + +-- VERY IMPORTANT for doctests to work: https://stackoverflow.com/a/58027909/1364288 +-- http://hackage.haskell.org/package/cabal-doctest +test-suite doctests + import: common + ghc-options: -threaded + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: doctests.hs + build-depends: + dep-t, + dep-t-dynamic, + dep-t-advice, + doctest ^>= 0.20, + diff --git a/lib/Dep/Checked.hs b/lib/Dep/Checked.hs --- a/lib/Dep/Checked.hs +++ b/lib/Dep/Checked.hs @@ -1,212 +1,212 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} - --- | __NOTE__: This module can only be used when your dependencies live in the 'Control.Monad.Dep.DepT' monad. --- Use 'Dep.SimpleChecked' instead when dependencies are handled in an 'Dep.Env.Constructor' phase. --- --- This module provides an environment which tracks the dependencies of --- components that are added to it, allowing you to check if all --- dependencies --- are satisfied before running the program logic. --- --- >>> :{ --- 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 :: CheckedEnv Identity (DynamicEnv Identity) IO --- env = mempty --- & checkedDep @Foo @'[] @'[MonadIO] (Identity (component \_ -> makeIOFoo)) --- & checkedDep @Bar @'[Foo] @'[] (Identity (component makeBar)) --- envReady :: DynamicEnv Identity (DepT (DynamicEnv Identity) IO) --- envReady = --- let Right (_, checked) = checkEnv env --- in checked --- :} --- --- >>> :{ --- runFromDep (pure envReady) bar "this is bar" --- :} --- this is bar --- --- An example of a failed check: --- --- >>> :{ --- badEnv :: CheckedEnv Identity (DynamicEnv Identity) IO --- badEnv = mempty --- & checkedDep @Bar @'[Foo] @'[] (Identity (component makeBar)) --- :} --- --- >>> :{ --- let Left missing = checkEnv badEnv --- in missing --- :} --- fromList [Foo] --- -module Dep.Checked - ( - -- * A checked environment - CheckedEnv, - checkedDep, - getUnchecked, - checkEnv, - -- * The dependency graph - DepGraph (..), - SomeMonadConstraintRep (..), - monadConstraintRep, - -- * Re-exports - mempty - ) where - -import Control.Monad.Dep -import Data.Functor.Compose -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.Hashable -import Data.Kind -import Data.Proxy -import Data.SOP (K (..)) -import Data.SOP qualified as SOP -import Data.SOP.NP -import Dep.Dynamic -import Dep.Dynamic.Internal -import Dep.Has -import Dep.Env -import GHC.TypeLits -import Type.Reflection qualified as R -import Data.Functor -import Algebra.Graph -import qualified Algebra.Graph.Bipartite.AdjacencyMap as Bipartite - --- | A dependency injection environment for components with effects in the monad @(DepT me_ m)@. --- Parameterized by an 'Applicative' phase @h@, the environment type constructor --- @me_@ used by the 'DepT' transformer, and the type @m@ of the base --- monad. -data CheckedEnv h me_ m = CheckedEnv DepGraph (DynamicEnv h (DepT me_ m)) - --- | Add a component to a 'CheckedEnv'. --- --- __TYPE APPLICATIONS REQUIRED__. You must provide three types using @TypeApplications@: --- --- * The type @r_@ of the parameterizable record we want to add to the environment. --- --- * The type-level list @rs@ of the components the @r_@ value depends on (might be empty). --- --- * The type-level list @mcs@ of the constraints the @r_@ value requires from the base monad (might be empty). --- --- It's impossible to add a component without explicitly listing all its dependencies. --- --- In addition, you must also provide the @h (r_ (DepT e_ n))@ value, an implementation of the component that comes --- wrapped in some 'Applicative'. Notice that this value must be sufficiently polymorphic. --- --- The @QuantifiedConstraint@ says that, whatever the environment the 'DepT' uses, if @DynamicEnv Identity n@ has a 'Has' --- constraint, the 'DepT' environment must also have that constraint. This is trivially true when they are the same type, --- but may also be true when the 'DepT' environment wraps the 'DynamicEnv' and defines passthrough 'Has' instances. -checkedDep :: - forall r_ rs mcs h me_ m. - ( SOP.All R.Typeable rs, - SOP.All R.Typeable mcs, - R.Typeable r_, - R.Typeable h, - R.Typeable me_, - R.Typeable m, - HasAll rs (DepT me_ m) (me_ (DepT me_ m)), - forall s_ z n. Has s_ n (DynamicEnv Identity n) => Has s_ n (me_ n), - Monad m, - MonadSatisfiesAll mcs (DepT me_ m) - ) => - -- | The wrapped component - ( forall e_ n. - ( HasAll rs (DepT e_ n) (e_ (DepT e_ n)), - Monad n, - MonadSatisfiesAll mcs (DepT e_ n) - ) => - h (r_ (DepT e_ n)) - ) -> - -- | The environment in which to insert - CheckedEnv h me_ m -> - CheckedEnv h me_ m -checkedDep f (CheckedEnv DepGraph {provided,required,depToDep,depToMonad} de) = - let demoteDep :: forall (x :: (Type -> Type) -> Type). R.Typeable x => K SomeDepRep x - demoteDep = K (depRep @x) - depReps = collapse_NP $ cpure_NP @R.Typeable @rs Proxy demoteDep - demoteMonadConstraint :: forall (x :: (Type -> Type) -> Constraint). R.Typeable x => K SomeMonadConstraintRep x - demoteMonadConstraint = K (SomeMonadConstraintRep (R.typeRep @x)) - monadConstraintReps = collapse_NP $ cpure_NP @R.Typeable @mcs Proxy demoteMonadConstraint - provided' = HashSet.insert (depRep @r_) provided - required' = foldr HashSet.insert required depReps - depGraph' = DepGraph { - provided = provided' - , required = required' - , depToDep = overlay depToDep $ edges $ (depRep @r_,) <$> depReps - , depToMonad = Bipartite.overlay depToMonad $ Bipartite.edges $ (depRep @r_,) <$> monadConstraintReps - } - in CheckedEnv depGraph' (insertDep (f @me_) de) - --- | '(<>)' might result in over-restrictive dependency graphs, because --- dependencies for colliding components are kept even as only one of the --- components is kept. -instance Semigroup (CheckedEnv h me_ m) where - CheckedEnv g1 env1 <> CheckedEnv g2 env2 = CheckedEnv (g1 <> g2) (env1 <> env2) - --- | 'mempty' is for creating the empty environment. -instance Monoid (CheckedEnv h me_ m) where - mempty = CheckedEnv mempty mempty - --- | Extract the underlying 'DynamicEnv' along with the dependency graph, without checking that all dependencies are satisfied. -getUnchecked :: CheckedEnv h me_ m -> (DepGraph, DynamicEnv h (DepT me_ m)) -getUnchecked (CheckedEnv g d) = (g, d) - --- | Either fail with a the set of missing dependencies, or --- succeed and produce the the underlying 'DynamicEnv' along with the --- dependency graph. -checkEnv :: CheckedEnv h me_ m -> Either (HashSet SomeDepRep) (DepGraph, DynamicEnv h (DepT me_ m)) -checkEnv (CheckedEnv g@DepGraph {required,provided} d) = - let missing = HashSet.difference required provided - in if HashSet.null missing - then Right (g, d) - else Left missing - --- $setup --- --- >>> :set -XTypeApplications --- >>> :set -XMultiParamTypeClasses --- >>> :set -XImportQualifiedPost --- >>> :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 Data.Function --- >>> import GHC.Generics (Generic) --- >>> import Dep.Has --- >>> import Dep.Env --- >>> import Dep.Dynamic --- >>> import Dep.Checked --- >>> import Dep.Advice (component, runFromDep) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} + +-- | __NOTE__: This module can only be used when your dependencies live in the 'Control.Monad.Dep.DepT' monad. +-- Use 'Dep.SimpleChecked' instead when dependencies are handled in an 'Dep.Env.Constructor' phase. +-- +-- This module provides an environment which tracks the dependencies of +-- components that are added to it, allowing you to check if all +-- dependencies +-- are satisfied before running the program logic. +-- +-- >>> :{ +-- 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 :: CheckedEnv Identity (DynamicEnv Identity) IO +-- env = mempty +-- & checkedDep @Foo @'[] @'[MonadIO] (Identity (component \_ -> makeIOFoo)) +-- & checkedDep @Bar @'[Foo] @'[] (Identity (component makeBar)) +-- envReady :: DynamicEnv Identity (DepT (DynamicEnv Identity) IO) +-- envReady = +-- let Right (_, checked) = checkEnv env +-- in checked +-- :} +-- +-- >>> :{ +-- runFromDep (pure envReady) bar "this is bar" +-- :} +-- this is bar +-- +-- An example of a failed check: +-- +-- >>> :{ +-- badEnv :: CheckedEnv Identity (DynamicEnv Identity) IO +-- badEnv = mempty +-- & checkedDep @Bar @'[Foo] @'[] (Identity (component makeBar)) +-- :} +-- +-- >>> :{ +-- let Left missing = checkEnv badEnv +-- in missing +-- :} +-- fromList [Foo] +-- +module Dep.Checked + ( + -- * A checked environment + CheckedEnv, + checkedDep, + getUnchecked, + checkEnv, + -- * The dependency graph + DepGraph (..), + SomeMonadConstraintRep (..), + monadConstraintRep, + -- * Re-exports + mempty + ) where + +import Control.Monad.Dep +import Data.Functor.Compose +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Hashable +import Data.Kind +import Data.Proxy +import Data.SOP (K (..)) +import Data.SOP qualified as SOP +import Data.SOP.NP +import Dep.Dynamic +import Dep.Dynamic.Internal +import Dep.Has +import Dep.Env +import GHC.TypeLits +import Type.Reflection qualified as R +import Data.Functor +import Algebra.Graph +import qualified Algebra.Graph.Bipartite.AdjacencyMap as Bipartite + +-- | A dependency injection environment for components with effects in the monad @(DepT me_ m)@. +-- Parameterized by an 'Applicative' phase @h@, the environment type constructor +-- @me_@ used by the 'DepT' transformer, and the type @m@ of the base +-- monad. +data CheckedEnv h me_ m = CheckedEnv DepGraph (DynamicEnv h (DepT me_ m)) + +-- | Add a component to a 'CheckedEnv'. +-- +-- __TYPE APPLICATIONS REQUIRED__. You must provide three types using @TypeApplications@: +-- +-- * The type @r_@ of the parameterizable record we want to add to the environment. +-- +-- * The type-level list @rs@ of the components the @r_@ value depends on (might be empty). +-- +-- * The type-level list @mcs@ of the constraints the @r_@ value requires from the base monad (might be empty). +-- +-- It's impossible to add a component without explicitly listing all its dependencies. +-- +-- In addition, you must also provide the @h (r_ (DepT e_ n))@ value, an implementation of the component that comes +-- wrapped in some 'Applicative'. Notice that this value must be sufficiently polymorphic. +-- +-- The @QuantifiedConstraint@ says that, whatever the environment the 'DepT' uses, if @DynamicEnv Identity n@ has a 'Has' +-- constraint, the 'DepT' environment must also have that constraint. This is trivially true when they are the same type, +-- but may also be true when the 'DepT' environment wraps the 'DynamicEnv' and defines passthrough 'Has' instances. +checkedDep :: + forall r_ rs mcs h me_ m. + ( SOP.All R.Typeable rs, + SOP.All R.Typeable mcs, + R.Typeable r_, + R.Typeable h, + R.Typeable me_, + R.Typeable m, + HasAll rs (DepT me_ m) (me_ (DepT me_ m)), + forall s_ z n. Has s_ n (DynamicEnv Identity n) => Has s_ n (me_ n), + Monad m, + MonadSatisfiesAll mcs (DepT me_ m) + ) => + -- | The wrapped component + ( forall e_ n. + ( HasAll rs (DepT e_ n) (e_ (DepT e_ n)), + Monad n, + MonadSatisfiesAll mcs (DepT e_ n) + ) => + h (r_ (DepT e_ n)) + ) -> + -- | The environment in which to insert + CheckedEnv h me_ m -> + CheckedEnv h me_ m +checkedDep f (CheckedEnv DepGraph {provided,required,depToDep,depToMonad} de) = + let demoteDep :: forall (x :: (Type -> Type) -> Type). R.Typeable x => K SomeDepRep x + demoteDep = K (depRep @x) + depReps = collapse_NP $ cpure_NP @R.Typeable @rs Proxy demoteDep + demoteMonadConstraint :: forall (x :: (Type -> Type) -> Constraint). R.Typeable x => K SomeMonadConstraintRep x + demoteMonadConstraint = K (SomeMonadConstraintRep (R.typeRep @x)) + monadConstraintReps = collapse_NP $ cpure_NP @R.Typeable @mcs Proxy demoteMonadConstraint + provided' = HashSet.insert (depRep @r_) provided + required' = foldr HashSet.insert required depReps + depGraph' = DepGraph { + provided = provided' + , required = required' + , depToDep = overlay depToDep $ edges $ (depRep @r_,) <$> depReps + , depToMonad = Bipartite.overlay depToMonad $ Bipartite.edges $ (depRep @r_,) <$> monadConstraintReps + } + in CheckedEnv depGraph' (insertDep (f @me_) de) + +-- | '(<>)' might result in over-restrictive dependency graphs, because +-- dependencies for colliding components are kept even as only one of the +-- components is kept. +instance Semigroup (CheckedEnv h me_ m) where + CheckedEnv g1 env1 <> CheckedEnv g2 env2 = CheckedEnv (g1 <> g2) (env1 <> env2) + +-- | 'mempty' is for creating the empty environment. +instance Monoid (CheckedEnv h me_ m) where + mempty = CheckedEnv mempty mempty + +-- | Extract the underlying 'DynamicEnv' along with the dependency graph, without checking that all dependencies are satisfied. +getUnchecked :: CheckedEnv h me_ m -> (DepGraph, DynamicEnv h (DepT me_ m)) +getUnchecked (CheckedEnv g d) = (g, d) + +-- | Either fail with a the set of missing dependencies, or +-- succeed and produce the the underlying 'DynamicEnv' along with the +-- dependency graph. +checkEnv :: CheckedEnv h me_ m -> Either (HashSet SomeDepRep) (DepGraph, DynamicEnv h (DepT me_ m)) +checkEnv (CheckedEnv g@DepGraph {required,provided} d) = + let missing = HashSet.difference required provided + in if HashSet.null missing + then Right (g, d) + else Left missing + +-- $setup +-- +-- >>> :set -XTypeApplications +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XImportQualifiedPost +-- >>> :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 Data.Function +-- >>> import GHC.Generics (Generic) +-- >>> import Dep.Has +-- >>> import Dep.Env +-- >>> import Dep.Dynamic +-- >>> import Dep.Checked +-- >>> import Dep.Advice (component, runFromDep) diff --git a/lib/Dep/Dynamic.hs b/lib/Dep/Dynamic.hs --- a/lib/Dep/Dynamic.hs +++ b/lib/Dep/Dynamic.hs @@ -1,273 +1,273 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | This module provies a dynamic version of a dependency injection --- environment. --- --- You don't need to declare beforehand what fields exist in the environment, --- you can simply add them using 'insertDep'. --- --- I might be useful for quick prototyping, or for when there is a big number --- of components and putting all of them in a conventional record would slow --- compilation. --- --- A 'Dep.Env.fixEnv'-based example: --- --- >>> :{ --- 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 :: DynamicEnv (Constructor (DynamicEnv Identity IO)) IO --- env = mempty --- & insertDep @Foo (constructor (\_ -> makeIOFoo)) --- & insertDep @Bar (constructor makeBar) --- envReady :: DynamicEnv Identity IO --- envReady = fixEnv env --- :} --- --- >>> :{ --- bar (dep envReady) "this is bar" --- :} --- this is bar --- --- The same example using 'Control.Monad.Dep.DepT' and 'Dep.Advice.component': --- --- >>> :{ --- env' :: DynamicEnv Identity (DepT (DynamicEnv Identity) IO) --- env' = mempty --- & insertDep @Foo (Identity (component (\_ -> makeIOFoo))) --- & insertDep @Bar (Identity (component makeBar)) --- :} --- --- >>> :{ --- runFromDep (pure env') bar "this is bar" --- :} --- this is bar --- --- Components are found by type. Use "Dep.Tagged" to disambiguate components of --- the same type. --- --- It's not checked at compilation time that the dependencies for all --- components in the environment are also present in the environment. A --- `DynamicEnv` exception will be thrown at run time whenever a component tries to --- find a dependency that doesn't exist: --- --- >>> :{ --- badEnv :: DynamicEnv Identity IO --- badEnv = mempty --- :} --- --- >>> :{ --- bar (dep badEnv) "this is bar" --- :} --- *** Exception: DepNotFound (Bar IO) --- --- See `Dep.Checked` and `Dep.SimpleChecked` for safer (but still dynamically typed) approaches. --- --- See also `Dep.Env.InductiveEnv` for a strongly-typed variant. -module Dep.Dynamic - ( - -- * A dynamic environment - DynamicEnv - , insertDep - , deleteDep - , DepNotFound (..) - , SomeDepRep (..) - , depRep - -- * Re-exports - , mempty - , Bare - , fromBare - , toBare - ) -where - -import Dep.Env -import Dep.Has -import Control.Applicative -import Control.Exception -import Data.Coerce -import Data.Function (fix) -import Data.Functor (($>), (<&>)) -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.Functor.Compose -import Data.Functor.Constant -import Data.Functor.Identity -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as H -import Data.Kind -import Data.Proxy -import Data.String -import Data.Dynamic -import Data.Type.Equality (type (==)) -import Data.Typeable -import GHC.Generics qualified as G -import GHC.Records -import GHC.TypeLits -import Type.Reflection qualified as R -import Data.Hashable -import Algebra.Graph -import Dep.Dynamic.Internal -import Data.Monoid - --- | A dependency injection environment for components with effects in the monad @m@. --- --- The components are wrapped in an 'Applicative' phase @h@, which will be --- 'Data.Functor.Identity.Identity' for \"ready-to-be-used\" environments. -newtype DynamicEnv (h :: Type -> Type) (m :: Type -> Type) - = DynamicEnv (HashMap SomeDepRep Dynamic) - --- | In '(<>)', the entry for the left map is kept. -deriving newtype instance Semigroup (DynamicEnv h m) - --- | 'mempty' is for creating the empty environment. -deriving newtype instance Monoid (DynamicEnv h m) - --- | Insert a record component wrapped in the environment's phase parameter @h@. -insertDep :: - forall r_ h m. - (Typeable r_, Typeable h, Typeable m) => - h (r_ m) -> - DynamicEnv h m -> - DynamicEnv h m -insertDep component (DynamicEnv dict) = - let key = SomeDepRep (R.typeRep @r_) - in DynamicEnv (H.insert key (toDyn component) dict) - --- | The record type to delete is supplied through a type application. -deleteDep :: - forall (r_ :: (Type -> Type) -> Type) h m. - Typeable r_ => - DynamicEnv h m -> - DynamicEnv h m -deleteDep (DynamicEnv dict) = - let key = SomeDepRep (R.typeRep @r_) - in DynamicEnv (H.delete key dict) - --- | 'DynamicEnv' has a 'Data.Has.Has' instance for every possible component. If the --- component is not actually in the environment, 'DepNotFound' is thrown. -instance (Typeable r_, Typeable m) => Has r_ m (DynamicEnv Identity m) where - dep (DynamicEnv dict) = - case H.lookup (SomeDepRep (R.typeRep @r_)) dict of - Nothing -> - throw (DepNotFound (typeRep (Proxy @(r_ m)))) - Just (d :: Dynamic) -> - case fromDynamic @(Identity (r_ m)) d of - Nothing -> error "Impossible failure converting dep." - Just (Identity component) -> component - --- | Exception thrown by 'dep' when the component we are looking for is not --- present in the environment. -newtype DepNotFound = DepNotFound TypeRep deriving (Show) - -instance Exception DepNotFound - --- | In 'liftH2', mismatches in key sets are resolved by working with their --- intersection, like how the @Apply@ instance for @Data.Map@ in the --- \"semigroupoids\" package works. -instance Phased DynamicEnv where - 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)) - -> DynamicEnv h m - -> f (DynamicEnv g m) - traverseH trans (DynamicEnv dict) = DynamicEnv <$> H.traverseWithKey dynTrans dict - where - withComponent :: forall (r_ :: (Type -> Type) -> Type) . Typeable r_ - => R.TypeRep r_ - -> Dynamic - -> f Dynamic - withComponent _ d = - case fromDynamic @(h (r_ m)) d of - Nothing -> error "Impossible failure converting dep." - Just hcomponent -> toDyn <$> trans hcomponent - dynTrans k d = case k of - SomeDepRep tr -> - R.withTypeable tr (withComponent tr d) - - 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) -> - -- | - DynamicEnv a m -> - -- | - DynamicEnv f m -> - -- | - DynamicEnv f' m - liftA2H trans (DynamicEnv dicta) (DynamicEnv dictb) = DynamicEnv (H.mapWithKey dynTrans (H.intersectionWith (,) dicta dictb)) - where - withComponent :: forall (r_ :: (Type -> Type) -> Type) . Typeable r_ - => R.TypeRep r_ - -> (Dynamic, Dynamic) - -> Dynamic - withComponent _ (da, df) = - case (fromDynamic @(a (r_ m)) da, fromDynamic @(f (r_ m)) df) of - (Nothing, _) -> error "Impossible failure converting left dep." - (_, Nothing) -> error "Impossible failure converting right dep." - (Just acomponent, Just fcomponent) -> toDyn (trans acomponent fcomponent) - dynTrans k dpair = case k of - SomeDepRep tr -> - R.withTypeable tr (withComponent tr dpair) - --- $setup --- --- >>> :set -XTypeApplications --- >>> :set -XMultiParamTypeClasses --- >>> :set -XImportQualifiedPost --- >>> :set -XStandaloneKindSignatures --- >>> :set -XNamedFieldPuns --- >>> :set -XFunctionalDependencies --- >>> :set -XFlexibleContexts --- >>> :set -XDataKinds --- >>> :set -XBlockArguments --- >>> :set -XFlexibleInstances --- >>> :set -XTypeFamilies --- >>> :set -XDeriveGeneric --- >>> :set -XViewPatterns --- >>> :set -XScopedTypeVariables --- >>> :set -XTypeOperators --- >>> import Data.Kind --- >>> import Control.Monad.Dep --- >>> import Data.Function --- >>> import GHC.Generics (Generic) --- >>> import Dep.Has --- >>> import Dep.Env --- >>> import Dep.Dynamic --- >>> import Dep.Advice (component, runFromDep) - +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | This module provies a dynamic version of a dependency injection +-- environment. +-- +-- You don't need to declare beforehand what fields exist in the environment, +-- you can simply add them using 'insertDep'. +-- +-- I might be useful for quick prototyping, or for when there is a big number +-- of components and putting all of them in a conventional record would slow +-- compilation. +-- +-- A 'Dep.Env.fixEnv'-based example: +-- +-- >>> :{ +-- 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 :: DynamicEnv (Constructor (DynamicEnv Identity IO)) IO +-- env = mempty +-- & insertDep @Foo (constructor (\_ -> makeIOFoo)) +-- & insertDep @Bar (constructor makeBar) +-- envReady :: DynamicEnv Identity IO +-- envReady = fixEnv env +-- :} +-- +-- >>> :{ +-- bar (dep envReady) "this is bar" +-- :} +-- this is bar +-- +-- The same example using 'Control.Monad.Dep.DepT' and 'Dep.Advice.component': +-- +-- >>> :{ +-- env' :: DynamicEnv Identity (DepT (DynamicEnv Identity) IO) +-- env' = mempty +-- & insertDep @Foo (Identity (component (\_ -> makeIOFoo))) +-- & insertDep @Bar (Identity (component makeBar)) +-- :} +-- +-- >>> :{ +-- runFromDep (pure env') bar "this is bar" +-- :} +-- this is bar +-- +-- Components are found by type. Use "Dep.Tagged" to disambiguate components of +-- the same type. +-- +-- It's not checked at compilation time that the dependencies for all +-- components in the environment are also present in the environment. A +-- `DynamicEnv` exception will be thrown at run time whenever a component tries to +-- find a dependency that doesn't exist: +-- +-- >>> :{ +-- badEnv :: DynamicEnv Identity IO +-- badEnv = mempty +-- :} +-- +-- >>> :{ +-- bar (dep badEnv) "this is bar" +-- :} +-- *** Exception: DepNotFound (Bar IO) +-- +-- See `Dep.Checked` and `Dep.SimpleChecked` for safer (but still dynamically typed) approaches. +-- +-- See also `Dep.Env.InductiveEnv` for a strongly-typed variant. +module Dep.Dynamic + ( + -- * A dynamic environment + DynamicEnv + , insertDep + , deleteDep + , DepNotFound (..) + , SomeDepRep (..) + , depRep + -- * Re-exports + , mempty + , Bare + , fromBare + , toBare + ) +where + +import Dep.Env +import Dep.Has +import Control.Applicative +import Control.Exception +import Data.Coerce +import Data.Function (fix) +import Data.Functor (($>), (<&>)) +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Functor.Compose +import Data.Functor.Constant +import Data.Functor.Identity +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as H +import Data.Kind +import Data.Proxy +import Data.String +import Data.Dynamic +import Data.Type.Equality (type (==)) +import Data.Typeable +import GHC.Generics qualified as G +import GHC.Records +import GHC.TypeLits +import Type.Reflection qualified as R +import Data.Hashable +import Algebra.Graph +import Dep.Dynamic.Internal +import Data.Monoid + +-- | A dependency injection environment for components with effects in the monad @m@. +-- +-- The components are wrapped in an 'Applicative' phase @h@, which will be +-- 'Data.Functor.Identity.Identity' for \"ready-to-be-used\" environments. +newtype DynamicEnv (h :: Type -> Type) (m :: Type -> Type) + = DynamicEnv (HashMap SomeDepRep Dynamic) + +-- | In '(<>)', the entry for the left map is kept. +deriving newtype instance Semigroup (DynamicEnv h m) + +-- | 'mempty' is for creating the empty environment. +deriving newtype instance Monoid (DynamicEnv h m) + +-- | Insert a record component wrapped in the environment's phase parameter @h@. +insertDep :: + forall r_ h m. + (Typeable r_, Typeable h, Typeable m) => + h (r_ m) -> + DynamicEnv h m -> + DynamicEnv h m +insertDep component (DynamicEnv dict) = + let key = SomeDepRep (R.typeRep @r_) + in DynamicEnv (H.insert key (toDyn component) dict) + +-- | The record type to delete is supplied through a type application. +deleteDep :: + forall (r_ :: (Type -> Type) -> Type) h m. + Typeable r_ => + DynamicEnv h m -> + DynamicEnv h m +deleteDep (DynamicEnv dict) = + let key = SomeDepRep (R.typeRep @r_) + in DynamicEnv (H.delete key dict) + +-- | 'DynamicEnv' has a 'Data.Has.Has' instance for every possible component. If the +-- component is not actually in the environment, 'DepNotFound' is thrown. +instance (Typeable r_, Typeable m) => Has r_ m (DynamicEnv Identity m) where + dep (DynamicEnv dict) = + case H.lookup (SomeDepRep (R.typeRep @r_)) dict of + Nothing -> + throw (DepNotFound (typeRep (Proxy @(r_ m)))) + Just (d :: Dynamic) -> + case fromDynamic @(Identity (r_ m)) d of + Nothing -> error "Impossible failure converting dep." + Just (Identity component) -> component + +-- | Exception thrown by 'dep' when the component we are looking for is not +-- present in the environment. +newtype DepNotFound = DepNotFound TypeRep deriving (Show) + +instance Exception DepNotFound + +-- | In 'liftH2', mismatches in key sets are resolved by working with their +-- intersection, like how the @Apply@ instance for @Data.Map@ in the +-- \"semigroupoids\" package works. +instance Phased DynamicEnv where + 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 . Typeable x => h x -> f (g x)) + -> DynamicEnv h m + -> f (DynamicEnv g m) + traverseH trans (DynamicEnv dict) = DynamicEnv <$> H.traverseWithKey dynTrans dict + where + withComponent :: forall (r_ :: (Type -> Type) -> Type) . Typeable r_ + => R.TypeRep r_ + -> Dynamic + -> f Dynamic + withComponent _ d = + case fromDynamic @(h (r_ m)) d of + Nothing -> error "Impossible failure converting dep." + Just hcomponent -> toDyn <$> trans hcomponent + dynTrans k d = case k of + SomeDepRep tr -> + R.withTypeable tr (withComponent tr d) + + liftA2H + :: forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) (m :: Type -> Type) . + ( Typeable a + , Typeable f + , Typeable f' + , Typeable m + ) => + (forall x. Typeable x => a x -> f x -> f' x) -> + -- | + DynamicEnv a m -> + -- | + DynamicEnv f m -> + -- | + DynamicEnv f' m + liftA2H trans (DynamicEnv dicta) (DynamicEnv dictb) = DynamicEnv (H.mapWithKey dynTrans (H.intersectionWith (,) dicta dictb)) + where + withComponent :: forall (r_ :: (Type -> Type) -> Type) . Typeable r_ + => R.TypeRep r_ + -> (Dynamic, Dynamic) + -> Dynamic + withComponent _ (da, df) = + case (fromDynamic @(a (r_ m)) da, fromDynamic @(f (r_ m)) df) of + (Nothing, _) -> error "Impossible failure converting left dep." + (_, Nothing) -> error "Impossible failure converting right dep." + (Just acomponent, Just fcomponent) -> toDyn (trans acomponent fcomponent) + dynTrans k dpair = case k of + SomeDepRep tr -> + R.withTypeable tr (withComponent tr dpair) + +-- $setup +-- +-- >>> :set -XTypeApplications +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XImportQualifiedPost +-- >>> :set -XStandaloneKindSignatures +-- >>> :set -XNamedFieldPuns +-- >>> :set -XFunctionalDependencies +-- >>> :set -XFlexibleContexts +-- >>> :set -XDataKinds +-- >>> :set -XBlockArguments +-- >>> :set -XFlexibleInstances +-- >>> :set -XTypeFamilies +-- >>> :set -XDeriveGeneric +-- >>> :set -XViewPatterns +-- >>> :set -XScopedTypeVariables +-- >>> :set -XTypeOperators +-- >>> import Data.Kind +-- >>> import Control.Monad.Dep +-- >>> import Data.Function +-- >>> import GHC.Generics (Generic) +-- >>> import Dep.Has +-- >>> import Dep.Env +-- >>> import Dep.Dynamic +-- >>> import Dep.Advice (component, runFromDep) + diff --git a/lib/Dep/Dynamic/Internal.hs b/lib/Dep/Dynamic/Internal.hs --- a/lib/Dep/Dynamic/Internal.hs +++ b/lib/Dep/Dynamic/Internal.hs @@ -1,154 +1,154 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Dep.Dynamic.Internal where - -import Dep.Env -import Dep.Has -import Control.Applicative -import Control.Exception -import Data.Coerce -import Data.Function (fix) -import Data.Functor (($>), (<&>)) -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.Functor.Compose -import Data.Functor.Constant -import Data.Functor.Identity -import Data.HashMap.Strict (HashMap) -import Data.HashMap.Strict qualified as H -import Data.Kind -import Data.Proxy -import Data.String -import Data.Type.Equality (type (==)) -import Data.Typeable -import GHC.Generics qualified as G -import GHC.Records -import GHC.TypeLits -import Type.Reflection qualified as R -import Data.Hashable -import Algebra.Graph -import qualified Algebra.Graph.Bipartite.AdjacencyMap as Bipartite - - --- | The type rep of a constraint over a monad. Similar to 'Type.Reflection.SomeTypeRep' --- but for types of a more specific kind. -data SomeMonadConstraintRep where - SomeMonadConstraintRep :: forall (a :: (Type -> Type) -> Constraint). !(R.TypeRep a) -> SomeMonadConstraintRep - -instance Eq SomeMonadConstraintRep where - SomeMonadConstraintRep r1 == SomeMonadConstraintRep r2 = R.SomeTypeRep r1 == R.SomeTypeRep r2 - -instance Ord SomeMonadConstraintRep where - SomeMonadConstraintRep r1 `compare` SomeMonadConstraintRep r2 = R.SomeTypeRep r1 `compare` R.SomeTypeRep r2 - -instance Hashable SomeMonadConstraintRep where - hashWithSalt salt (SomeMonadConstraintRep tr) = hashWithSalt salt tr - hash (SomeMonadConstraintRep tr) = hash tr - -instance Show SomeMonadConstraintRep where - show (SomeMonadConstraintRep r1) = show r1 - --- | Produce a 'SomeMonadConstraintRep' by means of a type application. -monadConstraintRep :: forall (mc :: (Type -> Type) -> Constraint) . R.Typeable mc => SomeMonadConstraintRep -monadConstraintRep = SomeMonadConstraintRep (R.typeRep @mc) - -type MonadSatisfiesAll :: [(Type -> Type) -> Constraint] -> (Type -> Type) -> Constraint -type family MonadSatisfiesAll cs m where - MonadSatisfiesAll '[] m = () - MonadSatisfiesAll (c : cs) m = (c m, MonadSatisfiesAll cs m) - --- | The type rep of a parameterizable record type. Similar to 'Type.Reflection.SomeTypeRep' --- but for types of a more specific kind. -data SomeDepRep where - SomeDepRep :: forall (a :: (Type -> Type) -> Type) . !(R.TypeRep a) -> SomeDepRep - -instance Eq SomeDepRep where - SomeDepRep r1 == SomeDepRep r2 = R.SomeTypeRep r1 == R.SomeTypeRep r2 - -instance Ord SomeDepRep where - SomeDepRep r1 `compare` SomeDepRep r2 = R.SomeTypeRep r1 `compare` R.SomeTypeRep r2 - -instance Hashable SomeDepRep where - hashWithSalt salt (SomeDepRep tr) = hashWithSalt salt tr - hash (SomeDepRep tr) = hash tr - -instance Show SomeDepRep where - show (SomeDepRep r1) = show r1 - --- | Produce a 'SomeDepRep' by means of a type application. -depRep :: forall (r_ :: (Type -> Type) -> Type) . R.Typeable r_ => SomeDepRep -depRep = SomeDepRep (R.typeRep @r_) - - - - --- | A summary graph of dependencies. --- If the required dependencies are not a subset of the provided ones, the environment is not yet complete. --- --- The graph datatypes come from the [algebraic-graphs](https://hackage.haskell.org/package/algebraic-graphs) package. -data DepGraph = DepGraph - { provided :: HashSet SomeDepRep, -- ^ components that have been inserted in the environment - required :: HashSet SomeDepRep, -- ^ components that are required by other components in the environment - depToDep :: Graph SomeDepRep, -- ^ graph with dependencies components have on other components - depToMonad :: Bipartite.AdjacencyMap SomeDepRep SomeMonadConstraintRep -- ^ bipartite graph with the constraints components require from the effect monad - } - -instance Semigroup DepGraph where - DepGraph {provided = provided1, required = required1, depToDep = depToDep1, depToMonad = depToMonad1} - <> DepGraph {provided = provided2, required = required2, depToDep = depToDep2, depToMonad = depToMonad2} = - DepGraph { provided = provided1 <> provided2 - , required = required1 <> required2 - , depToDep = overlay depToDep1 depToDep2 - , depToMonad = Bipartite.overlay depToMonad1 depToMonad2 - } - -instance Monoid DepGraph where - mempty = DepGraph mempty mempty Algebra.Graph.empty Bipartite.empty - - --- $setup --- --- >>> :set -XTypeApplications --- >>> :set -XMultiParamTypeClasses --- >>> :set -XImportQualifiedPost --- >>> :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 Data.Function --- >>> import GHC.Generics (Generic) --- >>> import Dep.Has --- >>> import Dep.Env --- >>> import Dep.Dynamic +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Dep.Dynamic.Internal where + +import Dep.Env +import Dep.Has +import Control.Applicative +import Control.Exception +import Data.Coerce +import Data.Function (fix) +import Data.Functor (($>), (<&>)) +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Functor.Compose +import Data.Functor.Constant +import Data.Functor.Identity +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as H +import Data.Kind +import Data.Proxy +import Data.String +import Data.Type.Equality (type (==)) +import Data.Typeable +import GHC.Generics qualified as G +import GHC.Records +import GHC.TypeLits +import Type.Reflection qualified as R +import Data.Hashable +import Algebra.Graph +import qualified Algebra.Graph.Bipartite.AdjacencyMap as Bipartite + + +-- | The type rep of a constraint over a monad. Similar to 'Type.Reflection.SomeTypeRep' +-- but for types of a more specific kind. +data SomeMonadConstraintRep where + SomeMonadConstraintRep :: forall (a :: (Type -> Type) -> Constraint). !(R.TypeRep a) -> SomeMonadConstraintRep + +instance Eq SomeMonadConstraintRep where + SomeMonadConstraintRep r1 == SomeMonadConstraintRep r2 = R.SomeTypeRep r1 == R.SomeTypeRep r2 + +instance Ord SomeMonadConstraintRep where + SomeMonadConstraintRep r1 `compare` SomeMonadConstraintRep r2 = R.SomeTypeRep r1 `compare` R.SomeTypeRep r2 + +instance Hashable SomeMonadConstraintRep where + hashWithSalt salt (SomeMonadConstraintRep tr) = hashWithSalt salt tr + hash (SomeMonadConstraintRep tr) = hash tr + +instance Show SomeMonadConstraintRep where + show (SomeMonadConstraintRep r1) = show r1 + +-- | Produce a 'SomeMonadConstraintRep' by means of a type application. +monadConstraintRep :: forall (mc :: (Type -> Type) -> Constraint) . R.Typeable mc => SomeMonadConstraintRep +monadConstraintRep = SomeMonadConstraintRep (R.typeRep @mc) + +type MonadSatisfiesAll :: [(Type -> Type) -> Constraint] -> (Type -> Type) -> Constraint +type family MonadSatisfiesAll cs m where + MonadSatisfiesAll '[] m = () + MonadSatisfiesAll (c : cs) m = (c m, MonadSatisfiesAll cs m) + +-- | The type rep of a parameterizable record type. Similar to 'Type.Reflection.SomeTypeRep' +-- but for types of a more specific kind. +data SomeDepRep where + SomeDepRep :: forall (a :: (Type -> Type) -> Type) . !(R.TypeRep a) -> SomeDepRep + +instance Eq SomeDepRep where + SomeDepRep r1 == SomeDepRep r2 = R.SomeTypeRep r1 == R.SomeTypeRep r2 + +instance Ord SomeDepRep where + SomeDepRep r1 `compare` SomeDepRep r2 = R.SomeTypeRep r1 `compare` R.SomeTypeRep r2 + +instance Hashable SomeDepRep where + hashWithSalt salt (SomeDepRep tr) = hashWithSalt salt tr + hash (SomeDepRep tr) = hash tr + +instance Show SomeDepRep where + show (SomeDepRep r1) = show r1 + +-- | Produce a 'SomeDepRep' by means of a type application. +depRep :: forall (r_ :: (Type -> Type) -> Type) . R.Typeable r_ => SomeDepRep +depRep = SomeDepRep (R.typeRep @r_) + + + + +-- | A summary graph of dependencies. +-- If the required dependencies are not a subset of the provided ones, the environment is not yet complete. +-- +-- The graph datatypes come from the [algebraic-graphs](https://hackage.haskell.org/package/algebraic-graphs) package. +data DepGraph = DepGraph + { provided :: HashSet SomeDepRep, -- ^ components that have been inserted in the environment + required :: HashSet SomeDepRep, -- ^ components that are required by other components in the environment + depToDep :: Graph SomeDepRep, -- ^ graph with dependencies components have on other components + depToMonad :: Bipartite.AdjacencyMap SomeDepRep SomeMonadConstraintRep -- ^ bipartite graph with the constraints components require from the effect monad + } + +instance Semigroup DepGraph where + DepGraph {provided = provided1, required = required1, depToDep = depToDep1, depToMonad = depToMonad1} + <> DepGraph {provided = provided2, required = required2, depToDep = depToDep2, depToMonad = depToMonad2} = + DepGraph { provided = provided1 <> provided2 + , required = required1 <> required2 + , depToDep = overlay depToDep1 depToDep2 + , depToMonad = Bipartite.overlay depToMonad1 depToMonad2 + } + +instance Monoid DepGraph where + mempty = DepGraph mempty mempty Algebra.Graph.empty Bipartite.empty + + +-- $setup +-- +-- >>> :set -XTypeApplications +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XImportQualifiedPost +-- >>> :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 Data.Function +-- >>> import GHC.Generics (Generic) +-- >>> import Dep.Has +-- >>> import Dep.Env +-- >>> import Dep.Dynamic -- >>> import Dep.Advice (component, runFromDep) diff --git a/lib/Dep/SimpleChecked.hs b/lib/Dep/SimpleChecked.hs --- a/lib/Dep/SimpleChecked.hs +++ b/lib/Dep/SimpleChecked.hs @@ -1,199 +1,199 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE BlockArguments #-} - --- | This module provides an environment which tracks the dependencies of --- components that are added to it, allowing you to check if all --- dependencies --- are satisfied before running the program logic. --- --- >>> :{ --- 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 :: CheckedEnv Identity IO --- env = mempty --- & checkedDep @Foo @'[] @'[MonadIO] (fromBare (\_ -> makeIOFoo)) --- & checkedDep @Bar @'[Foo] @'[] (fromBare makeBar) --- envReady :: DynamicEnv Identity IO --- envReady = --- let Right (_, pullPhase -> Identity checked) = checkEnv env --- in fixEnv checked --- :} --- --- >>> :{ --- bar (dep envReady) "this is bar" --- :} --- this is bar --- --- An example of a failed check: --- --- >>> :{ --- badEnv :: CheckedEnv Identity IO --- badEnv = mempty --- & checkedDep @Bar @'[Foo] @'[] (fromBare makeBar) --- :} --- --- >>> :{ --- let Left missing = checkEnv badEnv --- in missing --- :} --- fromList [Foo] --- -module Dep.SimpleChecked ( - -- * A checked environment - CheckedEnv, - checkedDep, - getUnchecked, - checkEnv, - -- * The dependency graph - DepGraph (..), - SomeMonadConstraintRep (..), - monadConstraintRep, - -- * Re-exports - mempty -) where - -import Data.Functor.Compose -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet -import Data.Hashable -import Data.Kind -import Data.Proxy -import Data.SOP (K (..)) -import Data.SOP qualified as SOP -import Data.SOP.NP -import Dep.Has -import Dep.Dynamic -import Dep.Dynamic.Internal -import Dep.Env -import GHC.TypeLits -import Type.Reflection qualified as R -import Data.Functor -import Algebra.Graph -import qualified Algebra.Graph.Bipartite.AdjacencyMap as Bipartite - --- | A dependency injection environment for components with effects in the monad @m@. --- Parameterized by an 'Applicative' phase @h@, and the type @m@ of the effect monad. -data CheckedEnv h m = CheckedEnv DepGraph (DynamicEnv (h `Compose` Constructor (DynamicEnv Identity m)) m) - --- | Add a component to a 'CheckedEnv'. --- --- __TYPE APPLICATIONS REQUIRED__. You must provide three types using @TypeApplications@: --- --- * The type @r_@ of the parameterizable record we want to add to the environment. --- --- * The type-level list @rs@ of the components the @r_@ value depends on (might be empty). --- --- * The type-level list @mcs@ of the constraints the @r_@ value requires from the base monad (might be empty). --- --- It's impossible to add a component without explicitly listing all its dependencies. --- --- In addition, you must also provide the @(h `Compose` Constructor e)@ value, an implementation of the component that comes --- wrapped in some 'Applicative'. Notice that this value must be sufficiently polymorphic. -checkedDep :: - forall r_ rs mcs h m. - ( SOP.All R.Typeable rs, - SOP.All R.Typeable mcs, - R.Typeable r_, - R.Typeable h, - R.Typeable m, - HasAll rs m (DynamicEnv Identity m), - Monad m, - MonadSatisfiesAll mcs m - ) => - -- | The wrapped component - ( forall e n. - ( HasAll rs n e, - Monad m, - MonadSatisfiesAll mcs n - ) => - (h `Compose` Constructor e) (r_ n) - ) -> - -- | The environment in which to insert - CheckedEnv h m -> - CheckedEnv h m -checkedDep f (CheckedEnv DepGraph {provided,required,depToDep,depToMonad} de) = - let demoteDep :: forall (x :: (Type -> Type) -> Type). R.Typeable x => K SomeDepRep x - demoteDep = K (depRep @x) - depReps = collapse_NP $ cpure_NP @R.Typeable @rs Proxy demoteDep - demoteMonadConstraint :: forall (x :: (Type -> Type) -> Constraint). R.Typeable x => K SomeMonadConstraintRep x - demoteMonadConstraint = K (SomeMonadConstraintRep (R.typeRep @x)) - monadConstraintReps = collapse_NP $ cpure_NP @R.Typeable @mcs Proxy demoteMonadConstraint - provided' = HashSet.insert (depRep @r_) provided - required' = foldr HashSet.insert required depReps - depGraph' = DepGraph { - provided = provided' - , required = required' - , depToDep = overlay depToDep $ edges $ (depRep @r_,) <$> depReps - , depToMonad = Bipartite.overlay depToMonad $ Bipartite.edges $ (depRep @r_,) <$> monadConstraintReps - } - in CheckedEnv depGraph' (insertDep (f @(DynamicEnv Identity m) @m) de) - --- | '(<>)' might result in over-restrictive dependency graphs, because --- dependencies for colliding components are kept even as only one of the --- components is kept. -instance Semigroup (CheckedEnv h m) where - CheckedEnv g1 env1 <> CheckedEnv g2 env2 = CheckedEnv (g1 <> g2) (env1 <> env2) - --- | 'mempty' is for creating the empty environment. -instance Monoid (CheckedEnv h m) where - mempty = CheckedEnv mempty mempty - --- | Extract the underlying 'DynamicEnv' along with the dependency graph, without checking that all dependencies are satisfied. -getUnchecked :: CheckedEnv h m -> (DepGraph, DynamicEnv (h `Compose` Constructor (DynamicEnv Identity m)) m) -getUnchecked (CheckedEnv g d) = (g, d) - --- | Either fail with a the set of missing dependencies, or --- succeed and produce the the underlying 'DynamicEnv' along with the --- dependency graph. -checkEnv :: CheckedEnv h m -> Either (HashSet SomeDepRep) (DepGraph, DynamicEnv (h `Compose` Constructor (DynamicEnv Identity m)) m) -checkEnv (CheckedEnv g@DepGraph {required,provided} d) = - let missing = HashSet.difference required provided - in if HashSet.null missing - then Right (g, d) - else Left missing - --- $setup --- --- >>> :set -XTypeApplications --- >>> :set -XMultiParamTypeClasses --- >>> :set -XImportQualifiedPost --- >>> :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 Data.Function --- >>> import GHC.Generics (Generic) --- >>> import Data.Either --- >>> import Dep.Has --- >>> import Dep.Env --- >>> import Dep.Dynamic --- >>> import Dep.SimpleChecked --- >>> import Dep.Advice (component, runFromDep) +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BlockArguments #-} + +-- | This module provides an environment which tracks the dependencies of +-- components that are added to it, allowing you to check if all +-- dependencies +-- are satisfied before running the program logic. +-- +-- >>> :{ +-- 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 :: CheckedEnv Identity IO +-- env = mempty +-- & checkedDep @Foo @'[] @'[MonadIO] (fromBare (\_ -> makeIOFoo)) +-- & checkedDep @Bar @'[Foo] @'[] (fromBare makeBar) +-- envReady :: DynamicEnv Identity IO +-- envReady = +-- let Right (_, pullPhase -> Identity checked) = checkEnv env +-- in fixEnv checked +-- :} +-- +-- >>> :{ +-- bar (dep envReady) "this is bar" +-- :} +-- this is bar +-- +-- An example of a failed check: +-- +-- >>> :{ +-- badEnv :: CheckedEnv Identity IO +-- badEnv = mempty +-- & checkedDep @Bar @'[Foo] @'[] (fromBare makeBar) +-- :} +-- +-- >>> :{ +-- let Left missing = checkEnv badEnv +-- in missing +-- :} +-- fromList [Foo] +-- +module Dep.SimpleChecked ( + -- * A checked environment + CheckedEnv, + checkedDep, + getUnchecked, + checkEnv, + -- * The dependency graph + DepGraph (..), + SomeMonadConstraintRep (..), + monadConstraintRep, + -- * Re-exports + mempty +) where + +import Data.Functor.Compose +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet +import Data.Hashable +import Data.Kind +import Data.Proxy +import Data.SOP (K (..)) +import Data.SOP qualified as SOP +import Data.SOP.NP +import Dep.Has +import Dep.Dynamic +import Dep.Dynamic.Internal +import Dep.Env +import GHC.TypeLits +import Type.Reflection qualified as R +import Data.Functor +import Algebra.Graph +import qualified Algebra.Graph.Bipartite.AdjacencyMap as Bipartite + +-- | A dependency injection environment for components with effects in the monad @m@. +-- Parameterized by an 'Applicative' phase @h@, and the type @m@ of the effect monad. +data CheckedEnv h m = CheckedEnv DepGraph (DynamicEnv (h `Compose` Constructor (DynamicEnv Identity m)) m) + +-- | Add a component to a 'CheckedEnv'. +-- +-- __TYPE APPLICATIONS REQUIRED__. You must provide three types using @TypeApplications@: +-- +-- * The type @r_@ of the parameterizable record we want to add to the environment. +-- +-- * The type-level list @rs@ of the components the @r_@ value depends on (might be empty). +-- +-- * The type-level list @mcs@ of the constraints the @r_@ value requires from the base monad (might be empty). +-- +-- It's impossible to add a component without explicitly listing all its dependencies. +-- +-- In addition, you must also provide the @(h `Compose` Constructor e)@ value, an implementation of the component that comes +-- wrapped in some 'Applicative'. Notice that this value must be sufficiently polymorphic. +checkedDep :: + forall r_ rs mcs h m. + ( SOP.All R.Typeable rs, + SOP.All R.Typeable mcs, + R.Typeable r_, + R.Typeable h, + R.Typeable m, + HasAll rs m (DynamicEnv Identity m), + Monad m, + MonadSatisfiesAll mcs m + ) => + -- | The wrapped component + ( forall e n. + ( HasAll rs n e, + Monad m, + MonadSatisfiesAll mcs n + ) => + (h `Compose` Constructor e) (r_ n) + ) -> + -- | The environment in which to insert + CheckedEnv h m -> + CheckedEnv h m +checkedDep f (CheckedEnv DepGraph {provided,required,depToDep,depToMonad} de) = + let demoteDep :: forall (x :: (Type -> Type) -> Type). R.Typeable x => K SomeDepRep x + demoteDep = K (depRep @x) + depReps = collapse_NP $ cpure_NP @R.Typeable @rs Proxy demoteDep + demoteMonadConstraint :: forall (x :: (Type -> Type) -> Constraint). R.Typeable x => K SomeMonadConstraintRep x + demoteMonadConstraint = K (SomeMonadConstraintRep (R.typeRep @x)) + monadConstraintReps = collapse_NP $ cpure_NP @R.Typeable @mcs Proxy demoteMonadConstraint + provided' = HashSet.insert (depRep @r_) provided + required' = foldr HashSet.insert required depReps + depGraph' = DepGraph { + provided = provided' + , required = required' + , depToDep = overlay depToDep $ edges $ (depRep @r_,) <$> depReps + , depToMonad = Bipartite.overlay depToMonad $ Bipartite.edges $ (depRep @r_,) <$> monadConstraintReps + } + in CheckedEnv depGraph' (insertDep (f @(DynamicEnv Identity m) @m) de) + +-- | '(<>)' might result in over-restrictive dependency graphs, because +-- dependencies for colliding components are kept even as only one of the +-- components is kept. +instance Semigroup (CheckedEnv h m) where + CheckedEnv g1 env1 <> CheckedEnv g2 env2 = CheckedEnv (g1 <> g2) (env1 <> env2) + +-- | 'mempty' is for creating the empty environment. +instance Monoid (CheckedEnv h m) where + mempty = CheckedEnv mempty mempty + +-- | Extract the underlying 'DynamicEnv' along with the dependency graph, without checking that all dependencies are satisfied. +getUnchecked :: CheckedEnv h m -> (DepGraph, DynamicEnv (h `Compose` Constructor (DynamicEnv Identity m)) m) +getUnchecked (CheckedEnv g d) = (g, d) + +-- | Either fail with a the set of missing dependencies, or +-- succeed and produce the the underlying 'DynamicEnv' along with the +-- dependency graph. +checkEnv :: CheckedEnv h m -> Either (HashSet SomeDepRep) (DepGraph, DynamicEnv (h `Compose` Constructor (DynamicEnv Identity m)) m) +checkEnv (CheckedEnv g@DepGraph {required,provided} d) = + let missing = HashSet.difference required provided + in if HashSet.null missing + then Right (g, d) + else Left missing + +-- $setup +-- +-- >>> :set -XTypeApplications +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XImportQualifiedPost +-- >>> :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 Data.Function +-- >>> import GHC.Generics (Generic) +-- >>> import Data.Either +-- >>> import Dep.Has +-- >>> import Dep.Env +-- >>> import Dep.Dynamic +-- >>> import Dep.SimpleChecked +-- >>> import Dep.Advice (component, runFromDep) diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -1,10 +1,10 @@ -module Main (main) where - -import Test.DocTest -main = doctest [ - "-ilib" - , "lib/Dep/Dynamic.hs" - , "lib/Dep/Dynamic/Internal.hs" - , "lib/Dep/Checked.hs" - , "lib/Dep/SimpleChecked.hs" - ] +module Main (main) where + +import Test.DocTest +main = doctest [ + "-ilib" + , "lib/Dep/Dynamic.hs" + , "lib/Dep/Dynamic/Internal.hs" + , "lib/Dep/Checked.hs" + , "lib/Dep/SimpleChecked.hs" + ] diff --git a/test/synthetic-callstack-tests.hs b/test/synthetic-callstack-tests.hs --- a/test/synthetic-callstack-tests.hs +++ b/test/synthetic-callstack-tests.hs @@ -1,663 +1,663 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | An example of how an application can make use of the "dep-t" and --- "dep-t-advice" packages for keeping a "synthetic" call stack that tracks the --- invocations of monadic functions, though only of those which take part in dependency --- injection. --- --- We are assuming that the application follows a "record-of-functions" style. -module Main (main) where - -import Control.Arrow ((>>>)) -import Control.Exception -import Control.Monad.Dep (DepT) -import Control.Monad.IO.Unlift -import Control.Monad.Reader -import Control.Monad.Trans.Cont -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Data.Functor.Compose -import Data.Functor.Const -import Data.Functor.Constant -import Data.Functor.Identity -import Data.IORef -import Data.List.NonEmpty (NonEmpty (..)) -import Data.List.NonEmpty qualified as NonEmpty -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Typeable -import Dep.Advice qualified as A -import Dep.Advice.Basic (MonadCallStack) -import Dep.Advice.Basic qualified as A -import Dep.Checked qualified as C -import Dep.Dynamic -import Dep.Env - ( Autowireable, - Autowired (..), - Constructor, - DemotableFieldNames, - FieldsFindableByType, - Phased, - bindPhase, - constructor, - demoteFieldNames, - fixEnv, - pullPhase, - skipPhase, - ) -import Dep.Has - ( Has (dep), - HasAll, - asCall, - ) -import Dep.SimpleAdvice - ( Advice, - AspectT (..), - Top, - adviseRecord, - advising, - makeExecutionAdvice, - ) -import Dep.SimpleAdvice.Basic - ( HasSyntheticCallStack (callStack), - MethodName, - StackFrame, - SyntheticCallStack, - SyntheticStackTrace, - SyntheticStackTraceException (SyntheticStackTraceException), - injectFailures, - keepCallStack, - ) -import Dep.SimpleChecked qualified as SC -import Dep.Tagged (Tagged (..), tagged, untag) -import GHC.Generics (Generic) -import GHC.TypeLits -import Lens.Micro (Lens', lens) -import System.IO -import Test.Tasty -import Test.Tasty.HUnit -import Prelude hiding (insert, lookup) -import Data.HashSet (HashSet) -import Data.HashSet qualified as HashSet - --- THE BUSINESS LOGIC --- --- - --- Component interfaces, defined as records polymorphic over the effect monad. -newtype Logger m = Logger - { emitMsg :: String -> m () - } - deriving stock (Generic) - -data Repository m = Repository - { insert :: Int -> m (), - lookup :: Int -> m Bool - } - deriving stock (Generic) - -newtype Controller m = Controller - { -- insert one arg, look up the other. Nonsensical, but good enough for an example. - route :: Int -> Int -> m Bool - } - deriving stock (Generic) - --- Component implementations, some of which depend on other components. --- -makeStdoutLogger :: MonadIO m => Logger m -makeStdoutLogger = Logger \msg -> liftIO $ putStrLn msg - --- allocation helper. -allocateSet :: Allocator (IORef (Set Int)) -allocateSet = ContT $ bracket (newIORef Set.empty) pure - --- When a component depends on another, it does so by taking an "env" parameter --- in the constructor and requiring 'Has' constraints on it. -makeInMemoryRepository :: - (Has Logger m env, MonadIO m) => - IORef (Set Int) -> - env -> - Repository m -makeInMemoryRepository ref (asCall -> call) = do - Repository - { insert = \key -> do - call emitMsg "inserting..." - theSet <- liftIO $ readIORef ref - liftIO $ writeIORef ref $ Set.insert key theSet, - lookup = \key -> do - call emitMsg "looking..." - theSet <- liftIO $ readIORef ref - pure (Set.member key theSet) - } - --- This implementation of Controller depends both on the Logger and the --- Repository. --- --- In general, the graph of dependencies between components can be a complex --- directed acyclic graph. -makeController :: - (Has Logger m env, Has Repository m env, Monad m) => - env -> - Controller m -makeController (asCall -> call) = - Controller - { route = \toInsert toLookup -> do - call emitMsg "serving..." - call insert toInsert - call emitMsg "before lookup..." - call lookup toLookup - } - -type MakeController2LoggersDeps = '[Logger, Tagged "secondary" Logger, Repository] - -makeController2Loggers :: - (HasAll MakeController2LoggersDeps m env, Monad m) => - env -> - Controller m -makeController2Loggers (asCall -> call) = - Controller - { route = \toInsert toLookup -> do - call (untag @"secondary" >>> emitMsg) "serving..." - call insert toInsert - call emitMsg "before lookup..." - call lookup toLookup - } - --- THE COMPOSITION ROOT --- --- Here we define our dependency injection environment. --- --- We put all the components which will form part of our application in an --- environment record. --- --- Each field is wrapped in a functor `h` which controls the "phases" we must --- go through in the construction of the environment. When `h` becomes --- Identity, the environment is ready for use. (This is an example of the --- "Higer-Kinded Data" pattern.) - --- The "phases" that components go through until fully built. Each phase --- is represented as an applicative functor. The succession of phases is --- defined using Data.Functor.Compose. --- -type Phases = Allocator - --- A phase in which we might allocate some resource needed by the component, --- also set some bracket-like resource management. --- The "managed" library could be used instead of ContT. -type Allocator = ContT () IO - --- Environment value --- --- The base monad is a 'ReaderT' holding a SyntheticCallStack value which gets modified --- using "local" for each sub-call. --- --- Notice that neither the interfaces nor the implementations which we defined --- earlier knew anything about the ReaderT. -env :: SC.CheckedEnv Phases (ReaderT SyntheticCallStack IO) -env = - SC.checkedDep @Logger @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateBombs 1 <&> \bombs -> - \_ -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method <> injectFailures bombs - ) - makeStdoutLogger - ) - . SC.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateBombs 0 <&> \bombs -> - \_ -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method <> injectFailures bombs - ) - (tagged @"secondary" makeStdoutLogger) - ) - . SC.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateSet <&> \ref -> - \env -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method - ) - (makeInMemoryRepository ref env) - ) - . SC.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - pure @Allocator $ - \env -> - makeController env - & advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method - ) - ) - $ mempty - - -envLoggerMissing :: SC.CheckedEnv Phases (ReaderT SyntheticCallStack IO) -envLoggerMissing = - SC.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateBombs 0 <&> \bombs -> - \_ -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method <> injectFailures bombs - ) - (tagged @"secondary" makeStdoutLogger) - ) - . SC.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateSet <&> \ref -> - \env -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method - ) - (makeInMemoryRepository ref env) - ) - . SC.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - pure @Allocator $ - \env -> - makeController env - & advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method - ) - ) - $ mempty - - --- Catch only IOExceptions for this example. -ioEx :: SomeException -> Maybe IOError -ioEx = fromException @IOError - --- Allocate a supply of potentially exception-throwing actions. -allocateBombs :: Int -> Allocator (IORef ([IO ()], [IO ()])) -allocateBombs whenToBomb = ContT $ bracket (newIORef bombs) pure - where - bombs = - ( replicate whenToBomb (pure ()) ++ repeat (throwIO (userError "oops")), - repeat (pure ()) - ) - --- THE COMPOSITION ROOT - ALTERNATIVE APPROACH --- --- --- Here we'll define the dependency injection environment in a slightly --- different way (but reusing both the "business logic" and the Env type). - --- The basic idea is that we don't perform dependency injection as a separate --- Applicative phase (so no Constructor, but a mere Identity phase). --- --- Instead, we shift that task into the base monad's environent. - --- As a result the "phases" are simpler: -type Phases' = Allocator `Compose` Identity - --- Now the expanded "runtime" environment will hold both the synthetic call --- stack and the components. We define this small helper datatype for that. It --- augments a preexisting environment with call-related info. -data CallEnv i e_ m = CallEnv - { _callInfo :: i, - _ops :: e_ m - } - --- Delegate all 'Has' queries to the inner environment. -instance Has r_ m (e_ m) => Has r_ m (CallEnv i e_ m) where - dep = dep . _ops - -instance HasSyntheticCallStack (CallEnv SyntheticCallStack e_ m) where - callStack = lens _callInfo (\(CallEnv _ ops) i' -> CallEnv i' ops) - --- Here use the DepT monad (a variant of ReaderT) as the base monad. --- --- The environment of DepT includes-just as before-the SyntheticCallStack value --- that is used to trace each sub-call. --- --- But now it also includes the dependency injection context with all the --- components. -env' :: C.CheckedEnv Phases' (CallEnv SyntheticCallStack (DynamicEnv Identity)) IO --- env' :: Env Phases' (DepT (CallEnv SyntheticCallStack (Env Identity)) IO) -env' = - C.checkedDep @Logger @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateBombs 1 <&> \bombs -> - A.component \_ -> - A.adviseRecord @Top @Top (\method -> - A.keepCallStack ioEx method <> A.injectFailures bombs) - makeStdoutLogger - ) - . C.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateBombs 0 <&> \bombs -> - A.component \_ -> - A.adviseRecord @Top @Top (\method -> - A.keepCallStack ioEx method <> A.injectFailures bombs) - (tagged @"secondary" makeStdoutLogger) - ) - . C.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateSet <&> \ref -> - A.component \env -> - A.adviseRecord @Top @Top (\method -> - A.keepCallStack ioEx method) - (makeInMemoryRepository ref env) - ) - . C.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - pure @Allocator $ - A.component \env -> - A.adviseRecord @Top @Top (\method -> - A.keepCallStack ioEx method) - (makeController env) - ) - $ mempty - - -envLoggerMissing' :: C.CheckedEnv Phases' (CallEnv SyntheticCallStack (DynamicEnv Identity)) IO --- env' :: Env Phases' (DepT (CallEnv SyntheticCallStack (Env Identity)) IO) -envLoggerMissing' = - C.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateBombs 0 <&> \bombs -> - A.component \_ -> - A.adviseRecord @Top @Top (\method -> - A.keepCallStack ioEx method <> A.injectFailures bombs) - (tagged @"secondary" makeStdoutLogger) - ) - . C.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateSet <&> \ref -> - A.component \env -> - A.adviseRecord @Top @Top (\method -> - A.keepCallStack ioEx method) - (makeInMemoryRepository ref env) - ) - . C.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - pure @Allocator $ - A.component \env -> - A.adviseRecord @Top @Top (\method -> - A.keepCallStack ioEx method) - (makeController env) - ) - $ mempty - - --- THE COMPOSITION ROOT - YET ANOTER APPROACH --- --- This approach also uses DepT, but not to carry the dependencies, only to carry --- the call stack (like ReaderT in the first approach). --- --- This is done by parameterizing DepT with Constant, which makes DepT --- behave almost as a regular ReaderT. --- --- What are the benefits of unsing DepT instead of ReaderT here? Well, basically --- being able to use runFinalDepT in the test, which feels somewhat cleaner than --- runReaderT. -type RT e m = DepT (Constant e) m - -env'' :: SC.CheckedEnv Phases (RT SyntheticCallStack IO) -env'' = - SC.checkedDep @Logger @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateBombs 1 <&> \bombs -> - \_ -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method <> injectFailures bombs - ) - makeStdoutLogger - ) - . SC.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateBombs 0 <&> \bombs -> - \_ -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method <> injectFailures bombs - ) - (tagged @"secondary" makeStdoutLogger) - ) - . SC.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - allocateSet <&> \ref -> - \env -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method - ) - (makeInMemoryRepository ref env) - ) - . SC.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] - ( fromBare $ - pure @Allocator $ - \env -> - makeController env - & advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method - ) - ) - $ mempty - --- TESTS --- --- -expectedException :: (IOError, SyntheticStackTrace) -expectedException = - ( userError "oops", - NonEmpty.fromList - [ NonEmpty.fromList [(typeRep (Proxy @Logger), "emitMsg")], - NonEmpty.fromList [(typeRep (Proxy @Repository), "insert")], - NonEmpty.fromList [(typeRep (Proxy @Controller), "route")] - ] - ) - -expectedExceptionTagged :: (IOError, SyntheticStackTrace) -expectedExceptionTagged = - ( userError "oops", - NonEmpty.fromList - [ NonEmpty.fromList - [ (typeRep (Proxy @Logger), "emitMsg"), - (typeRep (Proxy @(Tagged "secondary" Logger)), "unTagged") - ], - NonEmpty.fromList [(typeRep (Proxy @Controller), "route")] - ] - ) - --- Test the "Constructor"-based version of the environment. -testSyntheticCallStack :: Assertion -testSyntheticCallStack = do - let Right (_, denv) = SC.checkEnv env - allocators = pullPhase denv - action = - runContT allocators \constructors -> do - -- here we complete the construction of the environment - let (asCall -> call) = fixEnv constructors - flip - runReaderT - ([] :: SyntheticCallStack) -- the initial stack trace for the call - ( do - _ <- call route 1 2 - pure () - ) - me <- try @SyntheticStackTraceException action - case me of - Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> - assertEqual "exception with callstack" expectedException (ex, trace) - Right _ -> assertFailure "expected exception did not appear" - --- Test the "Constructor"-based version of the environment. -testSyntheticCallStackTagged :: Assertion -testSyntheticCallStackTagged = do - let Right (_, denv) = SC.checkEnv env - denv' = - insertDep @Controller - ( fromBare $ - pure @Allocator $ - \env -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method - ) - (makeController2Loggers env) - ) - denv - allocators = pullPhase denv' - action = - runContT allocators \constructors -> do - -- here we complete the construction of the environment - let (asCall -> call) = fixEnv constructors - flip - runReaderT - ([] :: SyntheticCallStack) -- the initial stack trace for the call - ( do - _ <- call route 1 2 - pure () - ) - me <- try @SyntheticStackTraceException action - case me of - Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> - assertEqual "exception with callstack" expectedExceptionTagged (ex, trace) - Right _ -> assertFailure "expected exception did not appear" - - --- Test that missing dependencies are correctly identified. -testMissingDeps :: Assertion -testMissingDeps = do - let Left missingDeps = SC.checkEnv envLoggerMissing - in assertEqual "Detected logger is missing" (HashSet.singleton (depRep @Logger)) missingDeps - --- Test the "DepT"-based version of the environment. -testSyntheticCallStack' :: Assertion -testSyntheticCallStack' = do - let Right (_, denv) = C.checkEnv env' - action = - runContT (pullPhase @Allocator denv) \runnable -> do - _ <- A.runFromDep (pure (CallEnv [] runnable)) route 1 2 - pure () - me <- try @SyntheticStackTraceException action - case me of - Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> - assertEqual "exception with callstack" expectedException (ex, trace) - Right _ -> assertFailure "expected exception did not appear" - -testSyntheticCallStackTagged' :: Assertion -testSyntheticCallStackTagged' = do - let Right (_, denv) = C.checkEnv env' - denv' = - insertDep @Controller - ( fromBare $ - pure @Allocator $ - A.component \env -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method - ) - (makeController2Loggers env) - ) - denv - action = - runContT (pullPhase @Allocator denv') \runnable -> do - _ <- A.runFromDep (pure (CallEnv [] runnable)) route 1 2 - pure () - me <- try @SyntheticStackTraceException action - case me of - Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> - assertEqual "exception with callstack" expectedExceptionTagged (ex, trace) - Right _ -> assertFailure "expected exception did not appear" - --- Test that missing dependencies are correctly identified. -testMissingDeps' :: Assertion -testMissingDeps' = do - let Left missingDeps = C.checkEnv envLoggerMissing' - in assertEqual "Detected logger is missing" (HashSet.singleton (depRep @Logger)) missingDeps - -testSyntheticCallStack'' :: Assertion -testSyntheticCallStack'' = do - let Right (_, denv) = SC.checkEnv env'' - allocators = pullPhase denv - action = - runContT allocators \constructors -> do - -- here we complete the construction of the environment - let (asCall -> call) = fixEnv constructors - A.runFinalDepT (pure (Constant [])) (call route) 1 2 - pure () - me <- try @SyntheticStackTraceException action - case me of - Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> - assertEqual "exception with callstack" expectedException (ex, trace) - Right _ -> assertFailure "expected exception did not appear" - --- Test the "Constructor"-based version of the environment. -testSyntheticCallStackTagged'' :: Assertion -testSyntheticCallStackTagged'' = do - let Right (_, denv) = SC.checkEnv env'' - denv' = - insertDep @Controller - ( fromBare $ - pure @Allocator $ - \env -> - advising - ( adviseRecord @Top @Top \method -> - keepCallStack ioEx method - ) - (makeController2Loggers env) - ) - denv - allocators = pullPhase denv' - action = - runContT allocators \constructors -> do - -- here we complete the construction of the environment - let (asCall -> call) = fixEnv constructors - A.runFinalDepT (pure (Constant [])) (call route) 1 2 - pure () - me <- try @SyntheticStackTraceException action - case me of - Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> - assertEqual "exception with callstack" expectedExceptionTagged (ex, trace) - Right _ -> assertFailure "expected exception did not appear" - -tests :: TestTree -tests = - testGroup - "All" - [ testCase "synthetic call stack" testSyntheticCallStack, - testCase "synthetic call stack with Tagged" testSyntheticCallStackTagged, - testCase "missing deps" testMissingDeps, - testCase "synthetic call stack - DepT" testSyntheticCallStack', - testCase "synthetic call stack with Tagged - DepT" testSyntheticCallStackTagged', - testCase "missing deps - DepT" testMissingDeps', - testCase "synthetic call stack - constructor + DepT" testSyntheticCallStack'', - testCase "synthetic call stack with Tagged - constructor + DepT" testSyntheticCallStackTagged'' - ] - -main :: IO () -main = defaultMain tests +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | An example of how an application can make use of the "dep-t" and +-- "dep-t-advice" packages for keeping a "synthetic" call stack that tracks the +-- invocations of monadic functions, though only of those which take part in dependency +-- injection. +-- +-- We are assuming that the application follows a "record-of-functions" style. +module Main (main) where + +import Control.Arrow ((>>>)) +import Control.Exception +import Control.Monad.Dep (DepT) +import Control.Monad.IO.Unlift +import Control.Monad.Reader +import Control.Monad.Trans.Cont +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Functor.Compose +import Data.Functor.Const +import Data.Functor.Constant +import Data.Functor.Identity +import Data.IORef +import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Typeable +import Dep.Advice qualified as A +import Dep.Advice.Basic (MonadCallStack) +import Dep.Advice.Basic qualified as A +import Dep.Checked qualified as C +import Dep.Dynamic +import Dep.Env + ( Autowireable, + Autowired (..), + Constructor, + DemotableFieldNames, + FieldsFindableByType, + Phased, + bindPhase, + constructor, + demoteFieldNames, + fixEnv, + pullPhase, + skipPhase, + ) +import Dep.Has + ( Has (dep), + HasAll, + asCall, + ) +import Dep.SimpleAdvice + ( Advice, + AspectT (..), + Top, + adviseRecord, + advising, + makeExecutionAdvice, + ) +import Dep.SimpleAdvice.Basic + ( HasSyntheticCallStack (callStack), + MethodName, + StackFrame, + SyntheticCallStack, + SyntheticStackTrace, + SyntheticStackTraceException (SyntheticStackTraceException), + injectFailures, + keepCallStack, + ) +import Dep.SimpleChecked qualified as SC +import Dep.Tagged (Tagged (..), tagged, untag) +import GHC.Generics (Generic) +import GHC.TypeLits +import Lens.Micro (Lens', lens) +import System.IO +import Test.Tasty +import Test.Tasty.HUnit +import Prelude hiding (insert, lookup) +import Data.HashSet (HashSet) +import Data.HashSet qualified as HashSet + +-- THE BUSINESS LOGIC +-- +-- + +-- Component interfaces, defined as records polymorphic over the effect monad. +newtype Logger m = Logger + { emitMsg :: String -> m () + } + deriving stock (Generic) + +data Repository m = Repository + { insert :: Int -> m (), + lookup :: Int -> m Bool + } + deriving stock (Generic) + +newtype Controller m = Controller + { -- insert one arg, look up the other. Nonsensical, but good enough for an example. + route :: Int -> Int -> m Bool + } + deriving stock (Generic) + +-- Component implementations, some of which depend on other components. +-- +makeStdoutLogger :: MonadIO m => Logger m +makeStdoutLogger = Logger \msg -> liftIO $ putStrLn msg + +-- allocation helper. +allocateSet :: Allocator (IORef (Set Int)) +allocateSet = ContT $ bracket (newIORef Set.empty) pure + +-- When a component depends on another, it does so by taking an "env" parameter +-- in the constructor and requiring 'Has' constraints on it. +makeInMemoryRepository :: + (Has Logger m env, MonadIO m) => + IORef (Set Int) -> + env -> + Repository m +makeInMemoryRepository ref (asCall -> call) = do + Repository + { insert = \key -> do + call emitMsg "inserting..." + theSet <- liftIO $ readIORef ref + liftIO $ writeIORef ref $ Set.insert key theSet, + lookup = \key -> do + call emitMsg "looking..." + theSet <- liftIO $ readIORef ref + pure (Set.member key theSet) + } + +-- This implementation of Controller depends both on the Logger and the +-- Repository. +-- +-- In general, the graph of dependencies between components can be a complex +-- directed acyclic graph. +makeController :: + (Has Logger m env, Has Repository m env, Monad m) => + env -> + Controller m +makeController (asCall -> call) = + Controller + { route = \toInsert toLookup -> do + call emitMsg "serving..." + call insert toInsert + call emitMsg "before lookup..." + call lookup toLookup + } + +type MakeController2LoggersDeps = '[Logger, Tagged "secondary" Logger, Repository] + +makeController2Loggers :: + (HasAll MakeController2LoggersDeps m env, Monad m) => + env -> + Controller m +makeController2Loggers (asCall -> call) = + Controller + { route = \toInsert toLookup -> do + call (untag @"secondary" >>> emitMsg) "serving..." + call insert toInsert + call emitMsg "before lookup..." + call lookup toLookup + } + +-- THE COMPOSITION ROOT +-- +-- Here we define our dependency injection environment. +-- +-- We put all the components which will form part of our application in an +-- environment record. +-- +-- Each field is wrapped in a functor `h` which controls the "phases" we must +-- go through in the construction of the environment. When `h` becomes +-- Identity, the environment is ready for use. (This is an example of the +-- "Higer-Kinded Data" pattern.) + +-- The "phases" that components go through until fully built. Each phase +-- is represented as an applicative functor. The succession of phases is +-- defined using Data.Functor.Compose. +-- +type Phases = Allocator + +-- A phase in which we might allocate some resource needed by the component, +-- also set some bracket-like resource management. +-- The "managed" library could be used instead of ContT. +type Allocator = ContT () IO + +-- Environment value +-- +-- The base monad is a 'ReaderT' holding a SyntheticCallStack value which gets modified +-- using "local" for each sub-call. +-- +-- Notice that neither the interfaces nor the implementations which we defined +-- earlier knew anything about the ReaderT. +env :: SC.CheckedEnv Phases (ReaderT SyntheticCallStack IO) +env = + SC.checkedDep @Logger @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateBombs 1 <&> \bombs -> + \_ -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method <> injectFailures bombs + ) + makeStdoutLogger + ) + . SC.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateBombs 0 <&> \bombs -> + \_ -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method <> injectFailures bombs + ) + (tagged @"secondary" makeStdoutLogger) + ) + . SC.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateSet <&> \ref -> + \env -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method + ) + (makeInMemoryRepository ref env) + ) + . SC.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + pure @Allocator $ + \env -> + makeController env + & advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method + ) + ) + $ mempty + + +envLoggerMissing :: SC.CheckedEnv Phases (ReaderT SyntheticCallStack IO) +envLoggerMissing = + SC.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateBombs 0 <&> \bombs -> + \_ -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method <> injectFailures bombs + ) + (tagged @"secondary" makeStdoutLogger) + ) + . SC.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateSet <&> \ref -> + \env -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method + ) + (makeInMemoryRepository ref env) + ) + . SC.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + pure @Allocator $ + \env -> + makeController env + & advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method + ) + ) + $ mempty + + +-- Catch only IOExceptions for this example. +ioEx :: SomeException -> Maybe IOError +ioEx = fromException @IOError + +-- Allocate a supply of potentially exception-throwing actions. +allocateBombs :: Int -> Allocator (IORef ([IO ()], [IO ()])) +allocateBombs whenToBomb = ContT $ bracket (newIORef bombs) pure + where + bombs = + ( replicate whenToBomb (pure ()) ++ repeat (throwIO (userError "oops")), + repeat (pure ()) + ) + +-- THE COMPOSITION ROOT - ALTERNATIVE APPROACH +-- +-- +-- Here we'll define the dependency injection environment in a slightly +-- different way (but reusing both the "business logic" and the Env type). + +-- The basic idea is that we don't perform dependency injection as a separate +-- Applicative phase (so no Constructor, but a mere Identity phase). +-- +-- Instead, we shift that task into the base monad's environent. + +-- As a result the "phases" are simpler: +type Phases' = Allocator `Compose` Identity + +-- Now the expanded "runtime" environment will hold both the synthetic call +-- stack and the components. We define this small helper datatype for that. It +-- augments a preexisting environment with call-related info. +data CallEnv i e_ m = CallEnv + { _callInfo :: i, + _ops :: e_ m + } + +-- Delegate all 'Has' queries to the inner environment. +instance Has r_ m (e_ m) => Has r_ m (CallEnv i e_ m) where + dep = dep . _ops + +instance HasSyntheticCallStack (CallEnv SyntheticCallStack e_ m) where + callStack = lens _callInfo (\(CallEnv _ ops) i' -> CallEnv i' ops) + +-- Here use the DepT monad (a variant of ReaderT) as the base monad. +-- +-- The environment of DepT includes-just as before-the SyntheticCallStack value +-- that is used to trace each sub-call. +-- +-- But now it also includes the dependency injection context with all the +-- components. +env' :: C.CheckedEnv Phases' (CallEnv SyntheticCallStack (DynamicEnv Identity)) IO +-- env' :: Env Phases' (DepT (CallEnv SyntheticCallStack (Env Identity)) IO) +env' = + C.checkedDep @Logger @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateBombs 1 <&> \bombs -> + A.component \_ -> + A.adviseRecord @Top @Top (\method -> + A.keepCallStack ioEx method <> A.injectFailures bombs) + makeStdoutLogger + ) + . C.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateBombs 0 <&> \bombs -> + A.component \_ -> + A.adviseRecord @Top @Top (\method -> + A.keepCallStack ioEx method <> A.injectFailures bombs) + (tagged @"secondary" makeStdoutLogger) + ) + . C.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateSet <&> \ref -> + A.component \env -> + A.adviseRecord @Top @Top (\method -> + A.keepCallStack ioEx method) + (makeInMemoryRepository ref env) + ) + . C.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + pure @Allocator $ + A.component \env -> + A.adviseRecord @Top @Top (\method -> + A.keepCallStack ioEx method) + (makeController env) + ) + $ mempty + + +envLoggerMissing' :: C.CheckedEnv Phases' (CallEnv SyntheticCallStack (DynamicEnv Identity)) IO +-- env' :: Env Phases' (DepT (CallEnv SyntheticCallStack (Env Identity)) IO) +envLoggerMissing' = + C.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateBombs 0 <&> \bombs -> + A.component \_ -> + A.adviseRecord @Top @Top (\method -> + A.keepCallStack ioEx method <> A.injectFailures bombs) + (tagged @"secondary" makeStdoutLogger) + ) + . C.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateSet <&> \ref -> + A.component \env -> + A.adviseRecord @Top @Top (\method -> + A.keepCallStack ioEx method) + (makeInMemoryRepository ref env) + ) + . C.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + pure @Allocator $ + A.component \env -> + A.adviseRecord @Top @Top (\method -> + A.keepCallStack ioEx method) + (makeController env) + ) + $ mempty + + +-- THE COMPOSITION ROOT - YET ANOTER APPROACH +-- +-- This approach also uses DepT, but not to carry the dependencies, only to carry +-- the call stack (like ReaderT in the first approach). +-- +-- This is done by parameterizing DepT with Constant, which makes DepT +-- behave almost as a regular ReaderT. +-- +-- What are the benefits of unsing DepT instead of ReaderT here? Well, basically +-- being able to use runFinalDepT in the test, which feels somewhat cleaner than +-- runReaderT. +type RT e m = DepT (Constant e) m + +env'' :: SC.CheckedEnv Phases (RT SyntheticCallStack IO) +env'' = + SC.checkedDep @Logger @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateBombs 1 <&> \bombs -> + \_ -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method <> injectFailures bombs + ) + makeStdoutLogger + ) + . SC.checkedDep @(Tagged "secondary" Logger) @'[] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateBombs 0 <&> \bombs -> + \_ -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method <> injectFailures bombs + ) + (tagged @"secondary" makeStdoutLogger) + ) + . SC.checkedDep @Repository @'[Logger] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + allocateSet <&> \ref -> + \env -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method + ) + (makeInMemoryRepository ref env) + ) + . SC.checkedDep @Controller @'[Logger, Repository] @'[MonadUnliftIO, MonadCallStack, MonadFail] + ( fromBare $ + pure @Allocator $ + \env -> + makeController env + & advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method + ) + ) + $ mempty + +-- TESTS +-- +-- +expectedException :: (IOError, SyntheticStackTrace) +expectedException = + ( userError "oops", + NonEmpty.fromList + [ NonEmpty.fromList [(typeRep (Proxy @Logger), "emitMsg")], + NonEmpty.fromList [(typeRep (Proxy @Repository), "insert")], + NonEmpty.fromList [(typeRep (Proxy @Controller), "route")] + ] + ) + +expectedExceptionTagged :: (IOError, SyntheticStackTrace) +expectedExceptionTagged = + ( userError "oops", + NonEmpty.fromList + [ NonEmpty.fromList + [ (typeRep (Proxy @Logger), "emitMsg"), + (typeRep (Proxy @(Tagged "secondary" Logger)), "unTagged") + ], + NonEmpty.fromList [(typeRep (Proxy @Controller), "route")] + ] + ) + +-- Test the "Constructor"-based version of the environment. +testSyntheticCallStack :: Assertion +testSyntheticCallStack = do + let Right (_, denv) = SC.checkEnv env + allocators = pullPhase denv + action = + runContT allocators \constructors -> do + -- here we complete the construction of the environment + let (asCall -> call) = fixEnv constructors + flip + runReaderT + ([] :: SyntheticCallStack) -- the initial stack trace for the call + ( do + _ <- call route 1 2 + pure () + ) + me <- try @SyntheticStackTraceException action + case me of + Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> + assertEqual "exception with callstack" expectedException (ex, trace) + Right _ -> assertFailure "expected exception did not appear" + +-- Test the "Constructor"-based version of the environment. +testSyntheticCallStackTagged :: Assertion +testSyntheticCallStackTagged = do + let Right (_, denv) = SC.checkEnv env + denv' = + insertDep @Controller + ( fromBare $ + pure @Allocator $ + \env -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method + ) + (makeController2Loggers env) + ) + denv + allocators = pullPhase denv' + action = + runContT allocators \constructors -> do + -- here we complete the construction of the environment + let (asCall -> call) = fixEnv constructors + flip + runReaderT + ([] :: SyntheticCallStack) -- the initial stack trace for the call + ( do + _ <- call route 1 2 + pure () + ) + me <- try @SyntheticStackTraceException action + case me of + Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> + assertEqual "exception with callstack" expectedExceptionTagged (ex, trace) + Right _ -> assertFailure "expected exception did not appear" + + +-- Test that missing dependencies are correctly identified. +testMissingDeps :: Assertion +testMissingDeps = do + let Left missingDeps = SC.checkEnv envLoggerMissing + in assertEqual "Detected logger is missing" (HashSet.singleton (depRep @Logger)) missingDeps + +-- Test the "DepT"-based version of the environment. +testSyntheticCallStack' :: Assertion +testSyntheticCallStack' = do + let Right (_, denv) = C.checkEnv env' + action = + runContT (pullPhase @Allocator denv) \runnable -> do + _ <- A.runFromDep (pure (CallEnv [] runnable)) route 1 2 + pure () + me <- try @SyntheticStackTraceException action + case me of + Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> + assertEqual "exception with callstack" expectedException (ex, trace) + Right _ -> assertFailure "expected exception did not appear" + +testSyntheticCallStackTagged' :: Assertion +testSyntheticCallStackTagged' = do + let Right (_, denv) = C.checkEnv env' + denv' = + insertDep @Controller + ( fromBare $ + pure @Allocator $ + A.component \env -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method + ) + (makeController2Loggers env) + ) + denv + action = + runContT (pullPhase @Allocator denv') \runnable -> do + _ <- A.runFromDep (pure (CallEnv [] runnable)) route 1 2 + pure () + me <- try @SyntheticStackTraceException action + case me of + Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> + assertEqual "exception with callstack" expectedExceptionTagged (ex, trace) + Right _ -> assertFailure "expected exception did not appear" + +-- Test that missing dependencies are correctly identified. +testMissingDeps' :: Assertion +testMissingDeps' = do + let Left missingDeps = C.checkEnv envLoggerMissing' + in assertEqual "Detected logger is missing" (HashSet.singleton (depRep @Logger)) missingDeps + +testSyntheticCallStack'' :: Assertion +testSyntheticCallStack'' = do + let Right (_, denv) = SC.checkEnv env'' + allocators = pullPhase denv + action = + runContT allocators \constructors -> do + -- here we complete the construction of the environment + let (asCall -> call) = fixEnv constructors + A.runFinalDepT (pure (Constant [])) (call route) 1 2 + pure () + me <- try @SyntheticStackTraceException action + case me of + Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> + assertEqual "exception with callstack" expectedException (ex, trace) + Right _ -> assertFailure "expected exception did not appear" + +-- Test the "Constructor"-based version of the environment. +testSyntheticCallStackTagged'' :: Assertion +testSyntheticCallStackTagged'' = do + let Right (_, denv) = SC.checkEnv env'' + denv' = + insertDep @Controller + ( fromBare $ + pure @Allocator $ + \env -> + advising + ( adviseRecord @Top @Top \method -> + keepCallStack ioEx method + ) + (makeController2Loggers env) + ) + denv + allocators = pullPhase denv' + action = + runContT allocators \constructors -> do + -- here we complete the construction of the environment + let (asCall -> call) = fixEnv constructors + A.runFinalDepT (pure (Constant [])) (call route) 1 2 + pure () + me <- try @SyntheticStackTraceException action + case me of + Left (SyntheticStackTraceException (fromException @IOError -> Just ex) trace) -> + assertEqual "exception with callstack" expectedExceptionTagged (ex, trace) + Right _ -> assertFailure "expected exception did not appear" + +tests :: TestTree +tests = + testGroup + "All" + [ testCase "synthetic call stack" testSyntheticCallStack, + testCase "synthetic call stack with Tagged" testSyntheticCallStackTagged, + testCase "missing deps" testMissingDeps, + testCase "synthetic call stack - DepT" testSyntheticCallStack', + testCase "synthetic call stack with Tagged - DepT" testSyntheticCallStackTagged', + testCase "missing deps - DepT" testMissingDeps', + testCase "synthetic call stack - constructor + DepT" testSyntheticCallStack'', + testCase "synthetic call stack with Tagged - constructor + DepT" testSyntheticCallStackTagged'' + ] + +main :: IO () +main = defaultMain tests diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -1,267 +1,267 @@ -{-# 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 #-} -{-# LANGUAGE TupleSections #-} - -module Main (main) where - -import Dep.Has -import Dep.Env -import Dep.Dynamic -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 -import Data.Typeable - -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) - -type Field = (,) String - -type Configurator = Kleisli Parser Value - -parseConf :: FromJSON a => Configurator a -parseConf = Kleisli parseJSON - -type Allocator = ContT () IO - -type Phases env = Field `Compose` Configurator `Compose` Allocator `Compose` Constructor env - -env :: DynamicEnv (Phases (DynamicEnv Identity IO)) IO -env = - insertDep @Logger (fromBare $ - ("logger",) $ - parseConf <&> \(LoggerConfiguration {messagePrefix}) -> - pure @Allocator $ - makeStdoutLogger messagePrefix) - $ insertDep @Repository (fromBare $ - ("repository",) $ - pure @Configurator $ - allocateMap <&> \ref -> - makeInMemoryRepository ref) - $ insertDep @Controller (fromBare $ - ("controller",) $ - pure @Configurator $ - pure @Allocator $ - makeController) - $ mempty - -env' :: Kleisli Parser Object (DynamicEnv (Allocator `Compose` Constructor (DynamicEnv Identity IO)) IO) -env' = traverseH trans env - where - trans (Compose (fieldName, Compose (Kleisli f))) = - Kleisli \o -> explicitParseField f o (fromString fieldName) - -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) = 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 - - -envMissing :: DynamicEnv (Phases (DynamicEnv Identity IO)) IO -envMissing = - insertDep ( - ("repository",()) `bindPhase` \() -> - skipPhase @Configurator $ - allocateMap `bindPhase` \ref -> - constructor (makeInMemoryRepository ref) - ) - $ insertDep ( - ("controller",()) `bindPhase` \() -> - skipPhase @Configurator $ - skipPhase @Allocator $ - constructor makeController - ) - $ mempty - - -envMissing' :: Kleisli Parser Object (DynamicEnv (Allocator `Compose` Constructor (DynamicEnv Identity IO)) IO) -envMissing' = traverseH trans envMissing - where - trans (Compose (fieldName, Compose (Kleisli f))) = - Kleisli \o -> explicitParseField f o (fromString fieldName) - - -testMissingDep :: Assertion -testMissingDep = do - let parseResult = eitherDecode' (fromString "{ \"logger\" : { \"messagePrefix\" : \"[foo]\" }, \"repository\" : null, \"controller\" : null }") - print parseResult - let Right value = parseResult - Kleisli (withObject "configuration" -> parser) = envMissing' - Right allocators = parseEither parser value - runContT (pullPhase @Allocator allocators) \constructors -> do - let (asCall -> call) = fixEnv constructors - e <- tryJust (fromException @DepNotFound) (call create) - case e of - Left (DepNotFound x) | x == typeRep (Proxy @(Logger IO)) -> pure () - _ -> assertFailure "exception expected" - - --- --- --- -tests :: TestTree -tests = - testGroup - "All" - [ - testCase "environmentConstruction" testEnvConstruction - , testCase "missing" testMissingDep - ] - -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 #-} +{-# LANGUAGE TupleSections #-} + +module Main (main) where + +import Dep.Has +import Dep.Env +import Dep.Dynamic +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 +import Data.Typeable + +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) + +type Field = (,) String + +type Configurator = Kleisli Parser Value + +parseConf :: FromJSON a => Configurator a +parseConf = Kleisli parseJSON + +type Allocator = ContT () IO + +type Phases env = Field `Compose` Configurator `Compose` Allocator `Compose` Constructor env + +env :: DynamicEnv (Phases (DynamicEnv Identity IO)) IO +env = + insertDep @Logger (fromBare $ + ("logger",) $ + parseConf <&> \(LoggerConfiguration {messagePrefix}) -> + pure @Allocator $ + makeStdoutLogger messagePrefix) + $ insertDep @Repository (fromBare $ + ("repository",) $ + pure @Configurator $ + allocateMap <&> \ref -> + makeInMemoryRepository ref) + $ insertDep @Controller (fromBare $ + ("controller",) $ + pure @Configurator $ + pure @Allocator $ + makeController) + $ mempty + +env' :: Kleisli Parser Object (DynamicEnv (Allocator `Compose` Constructor (DynamicEnv Identity IO)) IO) +env' = traverseH trans env + where + trans (Compose (fieldName, Compose (Kleisli f))) = + Kleisli \o -> explicitParseField f o (fromString fieldName) + +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) = 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 + + +envMissing :: DynamicEnv (Phases (DynamicEnv Identity IO)) IO +envMissing = + insertDep ( + ("repository",()) `bindPhase` \() -> + skipPhase @Configurator $ + allocateMap `bindPhase` \ref -> + constructor (makeInMemoryRepository ref) + ) + $ insertDep ( + ("controller",()) `bindPhase` \() -> + skipPhase @Configurator $ + skipPhase @Allocator $ + constructor makeController + ) + $ mempty + + +envMissing' :: Kleisli Parser Object (DynamicEnv (Allocator `Compose` Constructor (DynamicEnv Identity IO)) IO) +envMissing' = traverseH trans envMissing + where + trans (Compose (fieldName, Compose (Kleisli f))) = + Kleisli \o -> explicitParseField f o (fromString fieldName) + + +testMissingDep :: Assertion +testMissingDep = do + let parseResult = eitherDecode' (fromString "{ \"logger\" : { \"messagePrefix\" : \"[foo]\" }, \"repository\" : null, \"controller\" : null }") + print parseResult + let Right value = parseResult + Kleisli (withObject "configuration" -> parser) = envMissing' + Right allocators = parseEither parser value + runContT (pullPhase @Allocator allocators) \constructors -> do + let (asCall -> call) = fixEnv constructors + e <- tryJust (fromException @DepNotFound) (call create) + case e of + Left (DepNotFound x) | x == typeRep (Proxy @(Logger IO)) -> pure () + _ -> assertFailure "exception expected" + + +-- +-- +-- +tests :: TestTree +tests = + testGroup + "All" + [ + testCase "environmentConstruction" testEnvConstruction + , testCase "missing" testMissingDep + ] + +main :: IO () +main = defaultMain tests