dep-t 0.1.0.1 → 0.1.0.2
raw patch · 7 files changed
+542/−444 lines, 7 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +13/−9
- LICENSE +30/−30
- README.md +69/−23
- Setup.hs +2/−2
- dep-t.cabal +42/−42
- lib/Control/Monad/Dep.hs +146/−146
- test/tests.hs +240/−192
CHANGELOG.md view
@@ -1,9 +1,13 @@-# Revision history for dep-t--## 0.1.0.1 --* Minor documentation changes.--## 0.1.0.0 -- YYYY-mm-dd--* First version. Released on an unsuspecting world.+# Revision history for dep-t + +## 0.1.0.2 + +* Minor documentation changes. + +## 0.1.0.1 + +* Minor documentation changes. + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world.
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c) 2021, Daniel Diaz--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Daniel Diaz nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2021, Daniel Diaz + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Daniel Diaz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -46,13 +46,12 @@ Here's a function which obtains its dependencies from the environment record: - mkControllerIO :: (HasLogger e IO, HasRepository e IO) => Int -> ReaderT e IO Int+ mkControllerIO :: (HasLogger e IO, HasRepository e IO) => Int -> ReaderT e IO String mkControllerIO x = do- doLog <- asks logger- liftIO $ doLog "I'm going to insert in the db!"- insert <- asks repository- liftIO $ insert x- return $ x * x+ e <- ask+ liftIO $ logger e "I'm going to insert in the db!"+ liftIO $ repository e x+ return "view" That's all and well, but there are two issues that bug me: @@ -78,7 +77,7 @@ data Env m = Env { _logger :: String -> m (), _repository :: Int -> m (),- _controller :: Int -> m Int+ _controller :: Int -> m String } -- helper from the "rank2classes" package $(Rank2.TH.deriveFunctor ''Env)@@ -103,19 +102,18 @@ mkStdoutRepository :: (MonadReader e m, HasLogger e m, MonadIO m) => Int -> m () mkStdoutRepository entity = do- doLog <- asks logger- doLog "I'm going to write the entity!"+ e <- ask+ logger e "I'm going to write the entity!" liftIO $ print entity And here's the controller: - mkController :: (MonadReader e m, HasLogger e m, HasRepository e m) => Int -> m Int+ mkController :: (MonadReader e m, HasLogger e m, HasRepository e m) => Int -> m String mkController x = do- doLog <- asks logger- doLog "I'm going to insert in the db!"- insert <- asks repository- insert x- return $ x * x+ e <- ask+ logger e "I'm going to insert in the db!"+ repository e x+ return "view" Now, lets choose `IO` as the base monad and assemble an environment record: @@ -169,15 +167,10 @@ collecting the outputs of functions working as ["test doubles"](https://martinfowler.com/bliki/TestDouble.html). -## Invoking the functions in the environment is cumbersome--Yeah, it's annoying to perform the "ask for function, invoke function" dance each time:-- mkController x = do- doLog <- asks logger- doLog "I'm going to insert in the db!"+## How to avoid using "ask" or "asks" before invoking a dependency? -One workaround (at the cost of more boilerplate) is to define helper functions like: +One possible workaround (at the cost of more boilerplate) is to define helper+functions like: logger' :: (MonadReader e m, HasLogger e m) => String -> m () logger' msg = asks logger >>= \f -> f msg@@ -186,6 +179,59 @@ mkController x = do logger' "I'm going to insert in the db!"++I'm not sure it's worth the hassle.++## How to instrument functions in the environment?++Once we have commited to a concrete monad and constructed our+record-of-functions, we might indulge in a bit of low-calorie+aspect-oriented-programming.++For example, imagine we want a generic way of adding logging of function+parameters to any function in the environment, provided the environment already+contains a logging function.++We can write the following typeclass:++ class Instrumentable e m r | r -> e m where+ instrument ::+ ( forall x.+ HasLogger (e (DepT e m)) (DepT e m) =>+ [String] ->+ DepT e m x ->+ DepT e m x+ ) ->+ r ->+ r++Which means "if you tell me how to transform a terminal `DepT` action, using+the list of preceding arguments, in an environment that has as logger, then+I'll be able to transform any function which ends in `DepT`".++The terminal case is a `DepT` without preceding parameters:++ instance HasLogger (e (DepT e m)) (DepT e m) => Instrumentable e m (DepT e m x) where+ instrument f d = f [] d++The recursive case handles functions argument by argument:++ instance (Instrumentable e m r, Show a) => Instrumentable e m (a -> r) where+ instrument f ar =+ let instrument' = instrument @e @m @r+ in \a -> instrument' (\names d -> f (show a : names) d) (ar a)++Here's how to add logging advice to the controller function:++ instrumentedEnv :: Env (DepT Env (Writer TestTrace))+ instrumentedEnv =+ let loggingAdvice args action = do+ e <- ask+ logger e $ "advice before " ++ intercalate "," args+ r <- action+ logger e $ "advice after"+ pure r+ in env { _controller = instrument loggingAdvice (_controller env) } ## Caveats
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple +main = defaultMain
dep-t.cabal view
@@ -1,42 +1,42 @@-cabal-version: 3.0--name: dep-t-version: 0.1.0.1-synopsis: Reader-like monad transformer for dependency injection.-description: Put all your functions in the environment record! Let all- your functions read from the environment record! No favorites!--- bug-reports:-license: BSD-3-Clause-license-file: LICENSE-author: Daniel Diaz-maintainer: diaz_carrete@yahoo.com-category: Control-extra-source-files: CHANGELOG.md, README.md--source-repository head- type: git- location: https://github.com/danidiaz/dep-t.git--common common- build-depends: base >=4.10.0.0 && < 5,- transformers ^>= 0.5.0.0,- mtl ^>= 2.2,- unliftio-core ^>= 0.2.0.0,- default-language: Haskell2010--library- import: common- exposed-modules: Control.Monad.Dep- hs-source-dirs: lib --test-suite dep-t-test- import: common- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: tests.hs- build-depends: - dep-t, - rank2classes ^>= 1.4.1,- template-haskell,- tasty >= 1.3.1,- tasty-hunit >= 0.10.0.2,+cabal-version: 3.0 + +name: dep-t +version: 0.1.0.2 +synopsis: Reader-like monad transformer for dependency injection. +description: Put all your functions in the environment record! Let all + your functions read from the environment record! No favorites! +-- bug-reports: +license: BSD-3-Clause +license-file: LICENSE +author: Daniel Diaz +maintainer: diaz_carrete@yahoo.com +category: Control +extra-source-files: CHANGELOG.md, README.md + +source-repository head + type: git + location: https://github.com/danidiaz/dep-t.git + +common common + build-depends: base >=4.10.0.0 && < 5, + transformers ^>= 0.5.0.0, + mtl ^>= 2.2, + unliftio-core ^>= 0.2.0.0, + default-language: Haskell2010 + +library + import: common + exposed-modules: Control.Monad.Dep + hs-source-dirs: lib + +test-suite dep-t-test + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: tests.hs + build-depends: + dep-t, + rank2classes ^>= 1.4.1, + template-haskell, + tasty >= 1.3.1, + tasty-hunit >= 0.10.0.2,
lib/Control/Monad/Dep.hs view
@@ -1,146 +1,146 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE UndecidableInstances #-}---- |--- This package provides 'DepT', a monad transformer similar to 'ReaderT'.------ The difference is that the environment of 'DepT' must be parameterized by--- @DepT@'s own monad stack.------ There's a function 'withDepT' which is analogous to 'withReaderT'.------ There's no analogue of 'mapReaderT' however. This means you can't tweak--- the monad below the 'DepT' with a natural transformation.-module Control.Monad.Dep- ( DepT (DepT),- runDepT,- toReaderT,- withDepT,- zoomEnv,- )-where--import Control.Applicative-import Control.Monad.Cont.Class-import Control.Monad.Error.Class-import Control.Monad.IO.Unlift-import Control.Monad.Reader-import Control.Monad.State.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Identity-import Control.Monad.Writer.Class-import Control.Monad.Zip-import Data.Kind (Type)---- |--- A monad transformer which adds a read-only environment to the given monad.--- The environment type must be parameterized with the transformer's stack.------ The 'return' function ignores the environment, while @>>=@ passes the--- inherited environment to both subcomputations.-type DepT ::- ((Type -> Type) -> Type) ->- (Type -> Type) ->- Type ->- Type-newtype DepT env m r = DepT {toReaderT :: ReaderT (env (DepT env m)) m r}- deriving- ( Functor,- Applicative,- Alternative,- Monad,- MonadFix,- MonadFail,- MonadZip,- MonadPlus,- MonadCont,- MonadIO,- MonadUnliftIO,- MonadReader (env (DepT env m))- )--instance MonadTrans (DepT env) where- lift = DepT . lift--deriving instance MonadState s m => MonadState s (DepT env m)--deriving instance MonadWriter w m => MonadWriter w (DepT env m)--deriving instance MonadError e m => MonadError e (DepT env m)---- |--- Runs a 'DepT' action in an environment.-runDepT :: DepT env m r -> env (DepT env m) -> m r-runDepT = runReaderT . toReaderT---- |--- Changes the environment of a 'DepT', for example making the 'DepT' work in--- a "bigger" environment than the one in which was defined initially.------ The scary first parameter is a function that, given a natural--- transformation of monads, changes the monad parameter of the environment--- record. This function can be defined manually for each environment record,--- or it can be generated using TH from the "rank2classes" package.-withDepT ::- forall small big m a.- Monad m =>- -- | rank-2 map function- ( forall p q.- (forall x. p x -> q x) ->- small p ->- small q- ) ->- -- | get a small environment from a big one- (forall t. big t -> small t) ->- DepT small m a ->- DepT big m a-withDepT mapEnv inner (DepT (ReaderT f)) =- DepT- ( ReaderT- ( \big ->- let small :: small (DepT small m)- -- we have a big environment at hand, so let's extract the- -- small environment, transform every function in the small- -- environment by supplying the big environment and, as a- -- finishing touch, lift from the base monad m so that it- -- matches the monad expected by f.- small = mapEnv (lift . flip runDepT big) (inner big)- in f small- )- )---- |--- Makes the functions inside a small environment require a bigger environment.------ This can be useful if we are encasing the small environment as a field of--- the big environment, in order to make the types match.------ The scary first parameter is a function that, given a natural--- transformation of monads, changes the monad parameter of the environment--- record. This function can be defined manually for each environment record,--- or it can be generated using TH from the "rank2classes" package.---- For the reason for not inlining, see https://twitter.com/DiazCarrete/status/1350116413445439493-{-# NOINLINE zoomEnv #-}-zoomEnv ::- forall small big m a.- Monad m =>- -- | rank-2 map function- ( forall p q.- (forall x. p x -> q x) ->- small p ->- small q- ) ->- -- | get a small environment from a big one- (forall t. big t -> small t) ->- small (DepT small m) ->- small (DepT big m)-zoomEnv mapEnv inner = mapEnv (withDepT mapEnv inner)+{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- This package provides 'DepT', a monad transformer similar to 'ReaderT'. +-- +-- The difference is that the environment of 'DepT' must be parameterized by +-- @DepT@'s own monad stack. +-- +-- There's a function 'withDepT' which is analogous to 'withReaderT'. +-- +-- There's no analogue of 'mapReaderT' however. This means you can't tweak +-- the monad below the 'DepT' with a natural transformation. +module Control.Monad.Dep + ( DepT (DepT), + runDepT, + toReaderT, + withDepT, + zoomEnv, + ) +where + +import Control.Applicative +import Control.Monad.Cont.Class +import Control.Monad.Error.Class +import Control.Monad.IO.Unlift +import Control.Monad.Reader +import Control.Monad.State.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Identity +import Control.Monad.Writer.Class +import Control.Monad.Zip +import Data.Kind (Type) + +-- | +-- A monad transformer which adds a read-only environment to the given monad. +-- The environment type must be parameterized with the transformer's stack. +-- +-- The 'return' function ignores the environment, while @>>=@ passes the +-- inherited environment to both subcomputations. +type DepT :: + ((Type -> Type) -> Type) -> + (Type -> Type) -> + Type -> + Type +newtype DepT env m r = DepT {toReaderT :: ReaderT (env (DepT env m)) m r} + deriving + ( Functor, + Applicative, + Alternative, + Monad, + MonadFix, + MonadFail, + MonadZip, + MonadPlus, + MonadCont, + MonadIO, + MonadUnliftIO, + MonadReader (env (DepT env m)) + ) + +instance MonadTrans (DepT env) where + lift = DepT . lift + +deriving instance MonadState s m => MonadState s (DepT env m) + +deriving instance MonadWriter w m => MonadWriter w (DepT env m) + +deriving instance MonadError e m => MonadError e (DepT env m) + +-- | +-- Runs a 'DepT' action in an environment. +runDepT :: DepT env m r -> env (DepT env m) -> m r +runDepT = runReaderT . toReaderT + +-- | +-- Changes the environment of a 'DepT', for example making the 'DepT' work in +-- a "bigger" environment than the one in which was defined initially. +-- +-- The scary first parameter is a function that, given a natural +-- transformation of monads, changes the monad parameter of the environment +-- record. This function can be defined manually for each environment record, +-- or it can be generated using TH from the "rank2classes" package. +withDepT :: + forall small big m a. + Monad m => + -- | rank-2 map function + ( forall p q. + (forall x. p x -> q x) -> + small p -> + small q + ) -> + -- | get a small environment from a big one + (forall t. big t -> small t) -> + DepT small m a -> + DepT big m a +withDepT mapEnv inner (DepT (ReaderT f)) = + DepT + ( ReaderT + ( \big -> + let small :: small (DepT small m) + -- we have a big environment at hand, so let's extract the + -- small environment, transform every function in the small + -- environment by supplying the big environment and, as a + -- finishing touch, lift from the base monad m so that it + -- matches the monad expected by f. + small = mapEnv (lift . flip runDepT big) (inner big) + in f small + ) + ) + +-- | +-- Makes the functions inside a small environment require a bigger environment. +-- +-- This can be useful if we are encasing the small environment as a field of +-- the big environment, in order to make the types match. +-- +-- The scary first parameter is a function that, given a natural +-- transformation of monads, changes the monad parameter of the environment +-- record. This function can be defined manually for each environment record, +-- or it can be generated using TH from the "rank2classes" package. + +-- For the reason for not inlining, see https://twitter.com/DiazCarrete/status/1350116413445439493 +{-# NOINLINE zoomEnv #-} +zoomEnv :: + forall small big m a. + Monad m => + -- | rank-2 map function + ( forall p q. + (forall x. p x -> q x) -> + small p -> + small q + ) -> + -- | get a small environment from a big one + (forall t. big t -> small t) -> + small (DepT small m) -> + small (DepT big m) +zoomEnv mapEnv inner = mapEnv (withDepT mapEnv inner)
test/tests.hs view
@@ -1,192 +1,240 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE ImportQualifiedPost #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE StandaloneKindSignatures #-}-{-# LANGUAGE TemplateHaskell #-}--module Main (main) where--import Control.Monad.Dep-import Control.Monad.Reader-import Control.Monad.Writer-import Data.Kind-import Rank2 qualified-import Rank2.TH qualified-import Test.Tasty-import Test.Tasty.HUnit-import Prelude hiding (log)---- Some helper typeclasses.------ Has-style typeclasses can be provided to avoid depending on concrete--- environments.--- Note that the environment determines the monad.-type HasLogger :: Type -> (Type -> Type) -> Constraint-class HasLogger r m | r -> m where- logger :: r -> String -> m ()--logger' :: (MonadReader e m, HasLogger e m) => String -> m ()-logger' msg = asks logger >>= \f -> f msg--type HasRepository :: Type -> (Type -> Type) -> Constraint-class HasRepository r m | r -> m where- repository :: r -> Int -> m ()---- Some possible implementations.------ An implementation of the controller, done programming against interfaces--- (well, against typeclasses).--- Polymorphic on the monad.-mkController :: (MonadReader e m, HasLogger e m, HasRepository e m) => Int -> m Int-mkController x = do- doLog <- asks logger- doLog "I'm going to insert in the db!"- insert <- asks repository- insert x- return $ x * x---- A "real" logger implementation that interacts with the external world.-mkStdoutLogger :: MonadIO m => String -> m ()-mkStdoutLogger msg = liftIO (putStrLn msg)---- A "real" repository implementation -mkStdoutRepository :: (MonadReader e m, HasLogger e m, MonadIO m) => Int -> m ()-mkStdoutRepository entity = do- doLog <- asks logger- doLog "I'm going to write the entity!"- liftIO $ print entity---- The traces we accumulate from the fakes during tests-type TestTrace = ([String], [Int])---- A "fake". A pure implementation for tests.-mkFakeLogger :: MonadWriter TestTrace m => String -> m ()-mkFakeLogger msg = tell ([msg], [])---- Ditto.-mkFakeRepository :: (MonadReader e m, HasLogger e m, MonadWriter TestTrace m) => Int -> m ()-mkFakeRepository entity = do- doLog <- asks logger- doLog "I'm going to write the entity!"- tell ([], [entity])----------- Here we define a monomorphic environment working on IO-type EnvIO :: Type-data EnvIO = EnvIO- { _loggerIO :: String -> IO (),- _repositoryIO :: Int -> IO ()- }--instance HasLogger EnvIO IO where- logger = _loggerIO--instance HasRepository EnvIO IO where- repository = _repositoryIO---- In the monomorphic environment, the controller function lives "separate",--- having access to the logger and the repository through the ReaderT--- environment.------ The question is: the repository function *also* needs to know about the--- logger! Shouldn't it be aware of the ReaderT environment as well? Why--- privilege the controller function in such a manner?------ In a sufficiently complex app, the diverse functions will form a DAG of--- dependencies between each other. So it would be nice if the functions were--- treated uniformly, all having access to (views of) the environment record.-mkControllerIO :: (HasLogger e IO, HasRepository e IO) => Int -> ReaderT e IO Int-mkControllerIO x = do- doLog <- asks logger- liftIO $ doLog "I'm going to insert in the db!"- insert <- asks repository- liftIO $ insert x- return $ x * x---------- Here we define some polymorphic environments, which are basically--- records-of-functions parameterized by an effect monad.-type Env :: (Type -> Type) -> Type-data Env m = Env- { _logger :: String -> m (),- _repository :: Int -> m (),- _controller :: Int -> m Int- }-$(Rank2.TH.deriveFunctor ''Env)---- If our environment is parmeterized by the monad m, then logging is done in--- m.-instance HasLogger (Env m) m where- logger = _logger--instance HasRepository (Env m) m where- repository = _repository---- This bigger environment is for demonstrating how to "nest" environments.-type BiggerEnv :: (Type -> Type) -> Type-data BiggerEnv m = BiggerEnv- { _inner :: Env m,- _extra :: Int -> m Int- }-$(Rank2.TH.deriveFunctor ''BiggerEnv)---------- Creating environment values and commiting to a concrete monad.------ This is the first time DepT is used in this module.--- Note that it is only here where we settle for a concrete monad for the--- polymorphic environments.-env :: Env (DepT Env (Writer TestTrace))-env =- let _logger = mkFakeLogger- _repository = mkFakeRepository- _controller = mkController- in Env {_logger, _repository, _controller}---- An IO variant-envIO :: Env (DepT Env IO)-envIO =- let _logger = mkStdoutLogger- _repository = mkStdoutRepository- _controller = mkController- in Env {_logger, _repository, _controller}--biggerEnv :: BiggerEnv (DepT BiggerEnv (Writer TestTrace))-biggerEnv =- let -- We embed the small environment into the bigger one using "zoomEnv"- -- and the rank-2 fmap that allows us to change the monad which- -- parameterized the environment.- --- -- _inner' = (Rank2.<$>) (withDepT (Rank2.<$>) inner) env,- _inner' = zoomEnv (Rank2.<$>) _inner env- _extra = pure- in BiggerEnv {_inner = _inner', _extra}--biggerEnvIO :: BiggerEnv (DepT BiggerEnv IO)-biggerEnvIO =- let _inner' = zoomEnv (Rank2.<$>) _inner envIO- _extra = pure- in BiggerEnv {_inner = _inner', _extra}--expected :: TestTrace-expected = (["I'm going to insert in the db!", "I'm going to write the entity!"], [7])--tests :: TestTree-tests =- testGroup- "All"- [ testCase "hopeThisWorks" $- assertEqual "" expected $- execWriter $ runDepT ((_controller . _inner $ biggerEnv) 7) biggerEnv- ]--main :: IO ()-main = defaultMain tests+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main (main) where + +import Control.Monad.Dep +import Control.Monad.Reader +import Control.Monad.Writer +import Data.Kind +import Rank2 qualified +import Rank2.TH qualified +import Test.Tasty +import Test.Tasty.HUnit +import Prelude hiding (log) +import Data.List (intercalate) + +-- Some helper typeclasses. +-- +-- Has-style typeclasses can be provided to avoid depending on concrete +-- environments. +-- Note that the environment determines the monad. +type HasLogger :: Type -> (Type -> Type) -> Constraint +class HasLogger r m | r -> m where + logger :: r -> String -> m () + +-- Possible convenience function to avoid having to use ask before logging +-- Worth the extra boilerplate, or not? +logger' :: (MonadReader e m, HasLogger e m) => String -> m () +logger' msg = asks logger >>= \f -> f msg + +type HasRepository :: Type -> (Type -> Type) -> Constraint +class HasRepository r m | r -> m where + repository :: r -> Int -> m () + +-- Some possible implementations. +-- +-- An implementation of the controller, done programming against interfaces +-- (well, against typeclasses). +-- Polymorphic on the monad. +mkController :: (MonadReader e m, HasLogger e m, HasRepository e m) => Int -> m String +mkController x = do + e <- ask + logger e "I'm going to insert in the db!" + repository e x + return "view" + +-- A "real" logger implementation that interacts with the external world. +mkStdoutLogger :: MonadIO m => String -> m () +mkStdoutLogger msg = liftIO (putStrLn msg) + +-- A "real" repository implementation +mkStdoutRepository :: (MonadReader e m, HasLogger e m, MonadIO m) => Int -> m () +mkStdoutRepository entity = do + e <- ask + logger e "I'm going to write the entity!" + liftIO $ print entity + +-- The traces we accumulate from the fakes during tests +type TestTrace = ([String], [Int]) + +-- A "fake". A pure implementation for tests. +mkFakeLogger :: MonadWriter TestTrace m => String -> m () +mkFakeLogger msg = tell ([msg], []) + +-- Ditto. +mkFakeRepository :: (MonadReader e m, HasLogger e m, MonadWriter TestTrace m) => Int -> m () +mkFakeRepository entity = do + e <- ask + logger e "I'm going to write the entity!" + tell ([], [entity]) + +-- +-- +-- Here we define a monomorphic environment working on IO +type EnvIO :: Type +data EnvIO = EnvIO + { _loggerIO :: String -> IO (), + _repositoryIO :: Int -> IO () + } + +instance HasLogger EnvIO IO where + logger = _loggerIO + +instance HasRepository EnvIO IO where + repository = _repositoryIO + +-- In the monomorphic environment, the controller function lives "separate", +-- having access to the logger and the repository through the ReaderT +-- environment. +-- +-- The question is: the repository function *also* needs to know about the +-- logger! Shouldn't it be aware of the ReaderT environment as well? Why +-- privilege the controller function in such a manner? +-- +-- In a sufficiently complex app, the diverse functions will form a DAG of +-- dependencies between each other. So it would be nice if the functions were +-- treated uniformly, all having access to (views of) the environment record. +mkControllerIO :: (HasLogger e IO, HasRepository e IO) => Int -> ReaderT e IO String +mkControllerIO x = do + e <- ask + liftIO $ logger e "I'm going to insert in the db!" + liftIO $ repository e x + return "view" + +-- +-- +-- Here we define some polymorphic environments, which are basically +-- records-of-functions parameterized by an effect monad. +type Env :: (Type -> Type) -> Type +data Env m = Env + { _logger :: String -> m (), + _repository :: Int -> m (), + _controller :: Int -> m String + } + +$(Rank2.TH.deriveFunctor ''Env) + +-- If our environment is parmeterized by the monad m, then logging is done in +-- m. +instance HasLogger (Env m) m where + logger = _logger + +instance HasRepository (Env m) m where + repository = _repository + +-- This bigger environment is for demonstrating how to "nest" environments. +type BiggerEnv :: (Type -> Type) -> Type +data BiggerEnv m = BiggerEnv + { _inner :: Env m, + _extra :: Int -> m Int + } + +$(Rank2.TH.deriveFunctor ''BiggerEnv) + +-- +-- +-- Creating environment values and commiting to a concrete monad. +-- +-- This is the first time DepT is used in this module. +-- Note that it is only here where we settle for a concrete monad for the +-- polymorphic environments. +env :: Env (DepT Env (Writer TestTrace)) +env = + let _logger = mkFakeLogger + _repository = mkFakeRepository + _controller = mkController + in Env {_logger, _repository, _controller} + +-- An IO variant +envIO :: Env (DepT Env IO) +envIO = + let _logger = mkStdoutLogger + _repository = mkStdoutRepository + _controller = mkController + in Env {_logger, _repository, _controller} + +biggerEnv :: BiggerEnv (DepT BiggerEnv (Writer TestTrace)) +biggerEnv = + let -- We embed the small environment into the bigger one using "zoomEnv" + -- and the rank-2 fmap that allows us to change the monad which + -- parameterized the environment. + -- + -- _inner' = (Rank2.<$>) (withDepT (Rank2.<$>) inner) env, + _inner' = zoomEnv (Rank2.<$>) _inner env + _extra = pure + in BiggerEnv {_inner = _inner', _extra} + +biggerEnvIO :: BiggerEnv (DepT BiggerEnv IO) +biggerEnvIO = + let _inner' = zoomEnv (Rank2.<$>) _inner envIO + _extra = pure + in BiggerEnv {_inner = _inner', _extra} + +expected :: TestTrace +expected = (["I'm going to insert in the db!", "I'm going to write the entity!"], [7]) + +-- +-- +-- Experiment about adding instrumetation +class Instrumentable e m r | r -> e m where + instrument :: + ( forall x. + HasLogger (e (DepT e m)) (DepT e m) => + [String] -> + DepT e m x -> + DepT e m x + ) -> + r -> + r + +instance HasLogger (e (DepT e m)) (DepT e m) => Instrumentable e m (DepT e m x) where + instrument f d = f [] d + +instance (Instrumentable e m r, Show a) => Instrumentable e m (a -> r) where + instrument f ar = + let instrument' = instrument @e @m @r + in \a -> instrument' (\names d -> f (show a : names) d) (ar a) + +instrumentedEnv :: Env (DepT Env (Writer TestTrace)) +instrumentedEnv = + let loggingAdvice args action = do + e <- ask + logger e $ "advice before: " ++ intercalate "," args + r <- action + logger e $ "advice after" + pure r + in env { _controller = instrument loggingAdvice (_controller env) } + +expectedInstrumented :: TestTrace +expectedInstrumented = (["advice before: 7","I'm going to insert in the db!","I'm going to write the entity!","advice after"], [7]) +-- +-- +-- + +tests :: TestTree +tests = + testGroup + "All" + [ + testCase "hopeThisWorks" $ + assertEqual "" expected $ + execWriter $ runDepT ((_controller . _inner $ biggerEnv) 7) biggerEnv, + testCase "hopeAOPWorks" $ + assertEqual "" expectedInstrumented $ + execWriter $ runDepT ((_controller $ instrumentedEnv) 7) instrumentedEnv + ] + + +main :: IO () +main = defaultMain tests