dep-t 0.4.6.0 → 0.5.0.0

raw patch · 7 files changed

+252/−70 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +25/−16
• dep-t.cabal +4/−3
• lib/Control/Monad/Dep/Env.hs +112/−25
• lib/Control/Monad/Dep/Has.hs +3/−3
• test/tests_env.hs +19/−8
• test/tests_has.hs +82/−15

@@ -1,5 +1,12 @@ # Revision history for dep-t
 
+## 0.5.0.0
+
+* `Phased` now has `Typeable` constraints. Should be a mostly backwards compatible
+  change, as `Typeable` instances are automagically generated for most types.
+
+  Motivated by https://github.com/danidiaz/dep-t-dynamic/issues/1
+
 ## 0.4.6.0
 
 * added new module Control.Monad.Dep.Env with helpers for defining environments of records.

@@ -296,35 +296,37 @@ 
 - [The ReaderT design pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/).
 
-> Your application code will, in general, live in ReaderT Env IO. Define it as type App = ReaderT Env IO if you wish, or use a newtype wrapper instead of ReaderT directly.
+  > Your application code will, in general, live in ReaderT Env IO. Define it as type App = ReaderT Env IO if you wish, or use a newtype wrapper instead of ReaderT directly.
 
-> Optional: instead of directly using the App datatype, write your functions in terms of mtl-style typeclasses like MonadReader and MonadIO
+  > Optional: instead of directly using the App datatype, write your functions in terms of mtl-style typeclasses like MonadReader and MonadIO
 
 - [RIO](http://hackage.haskell.org/package/rio) is a featureful ReaderT-like /
   prelude replacement library which favors monomorphic environments.
 
 - The [van Laarhoven Free Monad](http://r6.ca/blog/20140210T181244Z.html).
 
-> Swierstra notes that by summing together functors representing primitive I/O
-> actions and taking the free monad of that sum, we can produce values use
-> multiple I/O feature sets. Values defined on a subset of features can be
-> lifted into the free monad generated by the sum. The equivalent process can
-> be performed with the van Laarhoven free monad by taking the product of
-> records of the primitive operations. Values defined on a subset of features
-> can be lifted by composing the van Laarhoven free monad with suitable
-> projection functions that pick out the requisite primitive operations. 
+  > Swierstra notes that by summing together functors representing primitive I/O
+  > actions and taking the free monad of that sum, we can produce values use
+  > multiple I/O feature sets. Values defined on a subset of features can be
+  > lifted into the free monad generated by the sum. The equivalent process can
+  > be performed with the van Laarhoven free monad by taking the product of
+  > records of the primitive operations. Values defined on a subset of features
+  > can be lifted by composing the van Laarhoven free monad with suitable
+  > projection functions that pick out the requisite primitive operations. 
 
+  [Another post](https://www.tweag.io/blog/2019-03-20-capability-free-monad/van) about the van Laarhoven Free Monad. Is it related to the final encoding of Free monads described [here](https://blog.poisson.chat/posts/2021-10-20-initial-final-free-monad.html)?
+
 - [Interesting SO response](https://stackoverflow.com/a/634754/1364288) (from
   2009) about the benefits of autowiring in Spring. The record-of-functions
   approach in Haskell can't be said to provide true autowiring. You still need
   to assemble the record manually, and field names in the record play the part
   of Spring bean names. 
 
-> Right now I think the most important reason for using autowiring is that
-> there's one less abstraction in your system to keep track of. The "bean name"
-> is effectively gone. It turns out the bean name only exists because of xml. So
-> a full layer of abstract indirections (where you would wire bean-name "foo"
-> into bean "bar") is gone
+  > Right now I think the most important reason for using autowiring is that
+  > there's one less abstraction in your system to keep track of. The "bean name"
+  > is effectively gone. It turns out the bean name only exists because of xml. So
+  > a full layer of abstract indirections (where you would wire bean-name "foo"
+  > into bean "bar") is gone
 
 - [registry](http://hackage.haskell.org/package/registry) is a package that
   implements an alternative approach to dependency injection, one different
@@ -332,5 +334,12 @@ 
 - [Printf("%s %s", dependency, injection)](https://www.fredrikholmqvist.com/posts/print-dependency-injection/). Commented on [HN](https://news.ycombinator.com/item?id=28915630), [Lobsters](https://lobste.rs/s/4axrt6/printf_s_s_dependency_injection).
 
-- [This book](https://www.goodreads.com/book/show/44416307-dependency-injection-principles-practices-and-patterns) about DI is good.
+- [Dependency Injection Principles, Practices, and
+  Patterns](https://www.goodreads.com/book/show/44416307-dependency-injection-principles-practices-and-patterns)
+  This is a good book on the general princples of DI. 
+
+- [Lessons learned while writing a Haskell
+  application](https://gvolpe.com/blog/lessons-learned-while-writing-a-haskell-app/).
+  This post recommends a "polymorphic record of functions" style, which fits
+  the philosophy of this library.
 

@@ -1,8 +1,8 @@ cabal-version:       3.0
 
 name:                dep-t
-version:             0.4.6.0
-synopsis:            Reader-like monad transformer for dependency injection.
+version:             0.5.0.0
+synopsis:            Dependency injection for records-of-functions.
 description:         Put all your functions in the environment record! Let all
                      your functions read from the environment record! No favorites!
 -- bug-reports:
@@ -69,7 +69,8 @@     tasty              >=  1.3.1,
     tasty-hunit        >=  0.10.0.2,
     sop-core           ^>= 0.5.0.0,
-    barbies            ^>= 2.0
+    barbies            ^>= 2.0,
+    containers
 
 test-suite dep-t-test-env
   import: common

@@ -48,10 +48,11 @@ --     repository :: h (Repository m),
 --     controller :: h (Controller m)
 --   } deriving stock Generic
--- -- deriving anyclass (FieldsFindableByType, DemotableFieldNames, Phased)
--- -- deriving via Autowired (EnvHKD Identity m) instance Autowireable r_ m (EnvHKD Identity m) => Has r_ m (EnvHKD Identity m)
+--     deriving anyclass (FieldsFindableByType, DemotableFieldNames, Phased)
+-- deriving via Autowired (EnvHKD Identity m) instance Autowireable r_ m (EnvHKD Identity m) => Has r_ m (EnvHKD Identity m)
 -- :}
 --
+--
 -- The module also provides a monad transformer-less way of performing dependency
 -- injection, by means of 'fixEnv'.
 --
@@ -109,6 +110,7 @@ import Data.Function (fix)
 import Data.String
 import Data.Type.Equality (type (==))
+import Data.Typeable
 
 -- $setup
 --
@@ -253,42 +255,112 @@ type Phased :: ((Type -> Type) -> (Type -> Type) -> Type) -> Constraint
 class Phased (env_ :: (Type -> Type) -> (Type -> Type) -> Type) where
     -- | Used to implement 'pullPhase' and 'mapPhase',  typically you should use those functions instead.
-    traverseH :: 
-        Applicative f 
-        => (forall x . h x -> f (g x)) -> env_ h m -> f (env_ g m)
+    traverseH 
+        :: forall (h :: Type -> Type) 
+                  (f :: Type -> Type) 
+                  (g :: Type -> Type) 
+                  (m :: Type -> Type). 
+        ( Applicative f 
+        , Typeable f
+        , Typeable g
+        , Typeable h
+        , Typeable m
+        ) => 
+        -- |
+        (forall x . h x -> f (g x)) ->
+        -- |
+        env_ h m ->
+        -- |
+        f (env_ g m)
     default traverseH 
-        :: ( G.Generic (env_ h m)
-           , G.Generic (env_ g m)
-           , GTraverseH h g (G.Rep (env_ h m)) (G.Rep (env_ g m))
-           , Applicative f )
+        :: forall (h :: Type -> Type) 
+                  (f :: Type -> Type) 
+                  (g :: Type -> Type) 
+                  (m :: Type -> Type). 
+        ( Applicative f 
+        , Typeable f
+        , Typeable g
+        , Typeable h
+        , Typeable m
+        , G.Generic (env_ h m)
+        , G.Generic (env_ g m)
+        , GTraverseH h g (G.Rep (env_ h m)) (G.Rep (env_ g m))
+        )
         => (forall x . h x -> f (g x)) -> env_ h m -> f (env_ g m)
     traverseH t env = G.to <$> gTraverseH t (G.from env)
     -- | Used to implement 'liftA2Phase', typically you should use that function instead.
-    liftA2H ::  (forall x. a x -> f x -> f' x) -> env_ a m -> env_ f m -> env_ f' m
+    liftA2H
+        :: forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) (m :: Type -> Type) .
+        ( Typeable a
+        , Typeable f
+        , Typeable f'
+        , Typeable m
+        )
+        => 
+        (forall x. a x -> f x -> f' x) -> 
+        -- |
+        env_ a m -> 
+        -- |
+        env_ f m -> 
+        -- |
+        env_ f' m
     default liftA2H
-        :: ( G.Generic (env_ a m)
-           , G.Generic (env_ f m)
-           , G.Generic (env_ f' m)
-           , GLiftA2Phase a f f' (G.Rep (env_ a m)) (G.Rep (env_ f m)) (G.Rep (env_ f' m))
-           )
+        :: forall (a :: Type -> Type) (f :: Type -> Type) (f' :: Type -> Type) m .
+        ( Typeable a
+        , Typeable f
+        , Typeable f'
+        , Typeable m
+        , G.Generic (env_ a m)
+        , G.Generic (env_ f m)
+        , G.Generic (env_ f' m)
+        , GLiftA2Phase a f f' (G.Rep (env_ a m)) (G.Rep (env_ f m)) (G.Rep (env_ f' m))
+        )
         => (forall x. a x -> f x -> f' x) -> env_ a m -> env_ f m -> env_ f' m
     liftA2H f enva env = G.to (gLiftA2Phase f (G.from enva) (G.from env))
 
 -- | Take the outermost phase wrapping each component and \"pull it outwards\",
 -- aggregating the phase's applicative effects.
-pullPhase :: forall f g env_ m . (Applicative f, Phased env_) => env_ (Compose f g) m -> f (env_ g m)
+pullPhase :: forall (f :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . (Phased env_, Applicative f, Typeable f, Typeable g, Typeable m) 
+          => 
+          -- |
+          env_ (Compose f g) m 
+          -> 
+          -- |
+          f (env_ g m)
 -- f first to help annotate the phase
-pullPhase = traverseH getCompose
+pullPhase = traverseH @env_ getCompose
 
 -- | Modify the outermost phase wrapping each component.
-mapPhase :: forall f' f g env_ m . Phased env_ => (forall x. f x -> f' x) -> env_ (Compose f g) m -> env_ (Compose f' g) m
+mapPhase :: forall (f :: Type -> Type) (f' :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . (Phased env_ , Typeable f, Typeable f', Typeable g, Typeable m) 
+         => 
+         -- |
+         (forall x. f x -> f' x) 
+         -> 
+         -- |
+         env_ (Compose f g) m 
+         -> 
+         -- |
+         env_ (Compose f' g) m
 -- f' first to help annotate the *target* of the transform?
-mapPhase f env = runIdentity $ traverseH (\(Compose fg) -> Identity (Compose (f fg))) env
+mapPhase f env = runIdentity $ traverseH @env_ (\(Compose fg) -> Identity (Compose (f fg))) env
 
 -- | Combine two environments with a function that works on their outermost phases.
-liftA2Phase :: forall f' a f g env_ m . Phased env_ => (forall x. a x -> f x -> f' x) -> env_ (Compose a g) m -> env_ (Compose f g) m -> env_ (Compose f' g) m
+liftA2Phase 
+    :: forall (a :: Type -> Type) (f' :: Type -> Type) (f :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . (Phased env_, Typeable a, Typeable f, Typeable f', Typeable g, Typeable m) 
+    => 
+    -- |
+    (forall x. a x -> f x -> f' x) 
+    -> 
+    -- |
+    env_ (Compose a g) m 
+    -> 
+    -- |
+    env_ (Compose f g) m 
+    -> 
+    -- |
+    env_ (Compose f' g) m
 -- f' first to help annotate the *target* of the transform?
-liftA2Phase f = liftA2H (\(Compose fa) (Compose fg) -> Compose (f fa fg))
+liftA2Phase f = liftA2H @env_ (\(Compose fa) (Compose fg) -> Compose (f fa fg))
 
 class GTraverseH h g env env' | env -> h, env' -> g where
     gTraverseH :: Applicative f => (forall x . h x -> f (g x)) -> env x -> f (env' x)
@@ -384,11 +456,26 @@ -- A typical usage is modifying a \"parsing the configuration\" phase so that
 -- each component looks into a different section of the global configuration
 -- field.
-mapPhaseWithFieldNames :: forall f' f g env_ m. (Phased env_, DemotableFieldNames env_) 
-    => (forall x. String -> f x -> f' x) -> env_ (Compose f g) m -> env_ (Compose f' g) m
+mapPhaseWithFieldNames :: 
+    forall (f :: Type -> Type) (f' :: Type -> Type) (g :: Type -> Type) (m :: Type -> Type) env_ . 
+    ( Phased env_ 
+    , DemotableFieldNames env_
+    , Typeable f
+    , Typeable f'
+    , Typeable g 
+    , Typeable m ) 
+    => 
+    -- |
+    (forall x. String -> f x -> f' x) 
+    -> 
+    -- |
+    env_ (Compose f g) m 
+    -> 
+    -- |
+    env_ (Compose f' g) m
 -- f' first to help annotate the *target* of the transform?
 mapPhaseWithFieldNames  f env =
-    liftA2Phase (\(Constant name) z -> f name z) (runIdentity $ traverseH (\(Constant z) -> Identity (Compose (Constant z))) demoteFieldNames) env
+    liftA2Phase (\(Constant name) z -> f name z) (runIdentity $ traverseH @env_ (\(Constant z) -> Identity (Compose (Constant z))) demoteFieldNames) env
 
 
 -- constructing phases
@@ -440,7 +527,7 @@ -- The @env_ (Constructor env_ m) m@ parameter might be the result of peeling
 -- away successive layers of applicative functor composition using 'pullPhase',
 -- until only the wiring phase remains.
-fixEnv :: Phased env_ => env_ (Constructor env_ m) m -> env_ Identity m
+fixEnv :: (Phased env_, Typeable env_, Typeable m) => env_ (Constructor env_ m) m -> env_ Identity m
 fixEnv env = fix (pullPhase env)
 
 -- | An inductively constructed environment with anonymous fields.

@@ -47,9 +47,9 @@ --      repository :: Repository m,
 --      controller :: Controller m
 --    }
---  -- instance Has Logger m (Env m)
---  -- instance Has Repository m (Env m)
---  -- instance Has Controller m (Env m)
+--  instance Has Logger m (Env m)
+--  instance Has Repository m (Env m)
+--  instance Has Controller m (Env m)
 --  :}
 --  
 -- 'Has' can be used in combination with 'MonadDep', like this:

@@ -28,6 +28,7 @@ 
 module Main (main) where
 
+import Control.Monad.Dep.Class
 import Control.Monad.Dep.Has
 import Control.Monad.Dep.Env
 import Control.Monad.Reader
@@ -52,7 +53,6 @@ import Control.Exception
 import Control.Arrow (Kleisli (..))
 import Data.Text qualified as Text
-import Data.ByteString.Lazy qualified as Bytes
 import Data.Function ((&))
 import Data.Functor ((<&>), ($>))
 import Data.String
@@ -128,10 +128,24 @@           call findById key 
     }
 
--- positional version of the controller constructor
-makeControllerPositionalArgs :: Monad m => Logger m -> Repository m -> Controller m
-makeControllerPositionalArgs a b = makeController $ addDep @Logger a $ addDep @Repository b $ emptyEnv
+-- 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
@@ -147,13 +161,10 @@ -- deriving via Autowired (EnvHKD Identity m) instance Has Repository m (EnvHKD Identity m)
 -- deriving via Autowired (EnvHKD Identity m) instance Has Controller m (EnvHKD Identity m)
 
--- phases :: Configurator (Allocator (Constructor env_ m (r_ m))) -> Phases env_ m (r_ m)
--- phases = coerce
+type Configurator = Kleisli Parser Value 
 
 parseConf :: FromJSON a => Configurator a
 parseConf = Kleisli parseJSON
-
-type Configurator = Kleisli Parser Value 
 
 type Allocator = ContT () IO
 

@@ -36,7 +36,7 @@ import Data.Coerce
 import Data.Kind
 import Data.List (intercalate)
-import Data.SOP
+import Data.SOP hiding (Compose)
 import GHC.Generics
 import Rank2 qualified
 import Rank2.TH qualified
@@ -47,6 +47,14 @@ import Data.Functor.Product
 import GHC.TypeLits
 import Barbies
+import Control.Monad.Trans.Cont
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.IORef
+import Data.Functor.Compose
+import Control.Exception hiding (TypeError)
+import System.IO
+import Data.Function
 
 -- https://stackoverflow.com/questions/53498707/cant-derive-generic-for-this-type/53499091#53499091
 -- There are indeed some higher kinded types for which GHC can currently derive Generic1 instances, but the feature is so limited it's hardly worth mentioning. This is mostly an artifact of taking the original implementation of Generic1 intended for * -> * (which already has serious limitations), turning on PolyKinds, and keeping whatever sticks, which is not much.
@@ -78,13 +86,11 @@   }
 
 instance Has Logger m (Env m)
-
 instance Has Repository m (Env m)
-
 instance Has Controller m (Env m)
 
-mkController :: forall d e m. MonadDep [Has Logger, Has Repository] d e m => Controller m
-mkController =
+makeController :: forall d e m. MonadDep [Has Logger, Has Repository] d e m => Controller m
+makeController =
   Controller \url -> 
     useEnv \(asCall -> call) -> do
       call log "I'm going to insert in the db!"
@@ -99,8 +105,8 @@ --   liftD (f e)
 
 -- better than with all that liftD spam... although slightly less flexible
-mkController' :: forall d e m. MonadDep [Has Logger, Has Repository] d e m => Controller m
-mkController' =
+makeController' :: forall d e m. MonadDep [Has Logger, Has Repository] d e m => Controller m
+makeController' =
   Controller \url ->
     useEnv \e -> do
       let (asCall -> call) = e
@@ -121,11 +127,11 @@ 
 type TestTrace = ([String], [Int])
 
-mkFakeLogger :: MonadWriter TestTrace m => Logger m
-mkFakeLogger = Logger \msg -> tell ([msg], [])
+makeFakeLogger :: MonadWriter TestTrace m => Logger m
+makeFakeLogger = Logger \msg -> tell ([msg], [])
 
-mkFakeRepository :: (MonadDep '[Has Logger] d e m, MonadWriter TestTrace m) => Repository m
-mkFakeRepository =
+makeFakeRepository :: (MonadDep '[Has Logger] d e m, MonadWriter TestTrace m) => Repository m
+makeFakeRepository =
   Repository
     { select = \_ -> do
         e <- ask
@@ -139,9 +145,9 @@ 
 env :: Env (DepT Env (Writer TestTrace))
 env =
-  let logger = mkFakeLogger
-      repository = mkFakeRepository
-      controller = mkController
+  let logger = makeFakeLogger
+      repository = makeFakeRepository
+      controller = makeController
    in Env {logger, repository, controller}
 
 --
@@ -152,6 +158,8 @@     repository :: h (Repository m),
     controller :: h (Controller m)
   }
+  deriving stock Generic
+  deriving anyclass (Phased)
 
 instance Has Logger m (EnvHKD I m)
 instance Has Repository m (EnvHKD I m)
@@ -181,6 +189,7 @@ 
 deriving via (Autowired (EnvHKD2 Identity m)) instance Has Logger m (EnvHKD2 Identity m)
 deriving via (Autowired (EnvHKD2 Identity m)) instance Has Repository m (EnvHKD2 Identity m)
+deriving via (Autowired (EnvHKD2 Identity m)) instance Has Controller m (EnvHKD2 Identity m)
 
 -- findLogger2 :: EnvHKD2 Identity m -> Logger m
 -- findLogger2 env = dep env
@@ -289,14 +298,72 @@     liftA2H f ax hx = tmap (\(Pair az hz) -> f az hz) $ tprod ax hx
 
 
+-- This is an example of how to combine the "Phased" approach 
+-- with DepT.
 --
+-- Notice that the "allocator" works in IO but the ultimate
+-- effect monad is a Writer.
 --
+-- Also the identity monad is I instead of Identity, 
+-- code works with both.
+type Allocator = ContT () IO
+
+type Phases = Allocator `Compose` I
+
+allocateMap :: ContT () IO (IORef (Map Int String))
+allocateMap = ContT $ bracket (newIORef Map.empty) pure
+
+envHKD :: EnvHKD Phases (DepT (EnvHKD I) (Writer TestTrace))
+envHKD =  EnvHKD {
+      logger = 
+        skipPhase @Allocator $
+        pure $ makeFakeLogger
+    , repository = 
+        allocateMap `bindPhase` \_ -> 
+        pure $ makeFakeRepository
+    , controller = 
+        skipPhase @Allocator $ 
+        pure $ makeController
+    } 
+
+testEnvHKD :: Assertion
+testEnvHKD = do
+    runContT (pullPhase @Allocator envHKD) \env -> do
+        let r = execWriter $ runDepT (do env <- ask; serve (dep env) 7) env
+        assertEqual "" (["I'm going to insert in the db!","I'm going to select an entity","I'm going to write the entity!"],[1,2,3,4]) r
+
 --
+-- Phased Approach + DepT, with an InductiveEnv
+-- InductiveEnv requires Identity as the final wrapping type, I doesn't work :(
+
+testEnvInductive :: Assertion
+testEnvInductive = do
+    let envInductive =
+              EmptyEnv 
+            & AddDep (skipPhase @Allocator $
+                      Identity $ makeFakeLogger) 
+            & AddDep (allocateMap `bindPhase` \_ -> 
+                      Identity $ makeFakeRepository)
+            & AddDep (skipPhase @Allocator $ 
+                      Identity $ makeController)
+    runContT (pullPhase @Allocator envInductive) \env -> do
+        let r = execWriter $ runDepT (do env <- ask; serve (dep env) 7) env
+        assertEqual "" (["I'm going to insert in the db!","I'm going to select an entity","I'm going to write the entity!"],[1,2,3,4]) r
+
+--
+--
+--
 tests :: TestTree
 tests =
   testGroup
     "All"
-    []
+    [
+      testCase "non HKD, pure" $
+              assertEqual "" (["I'm going to insert in the db!","I'm going to select an entity","I'm going to write the entity!"],[1,2,3,4]) $
+              execWriter $ runDepT (do env <- ask; serve (dep env) 7) env
+    , testCase "HKD, phased, uses I, pure" $ testEnvHKD
+    , testCase "HKD, InductiveEnv, uses Identity" $ testEnvInductive
+    ]
 
 main :: IO ()
 main = defaultMain tests