hierarchical-env 0.1.0.0 → 0.2.0.0

raw patch · 8 files changed

+193/−119 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• hierarchical-env.cabal +5/−4
• src/Control/Env/Hierarchical.hs +10/−14
• src/Control/Env/Hierarchical/Internal.hs +69/−37
• src/Control/Env/Hierarchical/TH.hs +29/−34
• test/Control/Env/Hierarchical/InternalSpec.hs +48/−16
• test/Control/Env/Hierarchical/THSpec.hs +8/−1
• test/Control/Env/HierarchicalSpec.hs +6/−13

@@ -1,5 +1,23 @@ # Revision history for hierarchical-env +## 0.2.0.0 -- 2021-04-28+* Change how to specify the super environment+  * Before: Specify by adding type instance for `Super env`+    +    ```haskell+    data Env = Env !BaseEnv !Int+    deriveEnv ''Env+    type instance Super Env = BaseEnv+    ```+  * After: Wrapping the super environment field with `Extends`++    ```haskell+    data Env = Env !(Extends BaseEnv) !Int+    deriveEnv ''Env+    ```+* Fix the type error bug occurs when hiding dependencies.++ ## 0.1.0.0 -- 2021-04-22  * First version. Released on an unsuspecting world.

@@ -5,10 +5,11 @@ -- http://haskell.org/cabal/users-guide/  name:               hierarchical-env-version:            0.1.0.0+version:            0.2.0.0 synopsis:           hierarchical environments for dependency injection+description:+  This library provides scalable dependency injection for RIO monad -description:        This library provides scalable dependency injection for RIO monad homepage:           https://github.com/autotaker/hierarchical-env  -- bug-reports:@@ -18,7 +19,7 @@ maintainer:         autotaker@gmail.com  -- copyright:-category: Control+category:           Control extra-source-files:   CHANGELOG.md   README.md@@ -31,7 +32,7 @@     , microlens-mtl     ^>=0.2     , microlens-th      ^>=0.4     , rio               >=0.1.16.0-    , template-haskell  >=2.15 && < 2.18+    , template-haskell  >=2.15     && <2.18     , th-abstraction    ^>=0.4.2.0    default-language: Haskell2010

@@ -24,8 +24,8 @@      -- ** With hierarchical environments     -- $usage:hierarchical-    Root,-    Super,+    Environment (Super, superL),+    Extends (Extends),     deriveEnv,      -- * Hiding dependencies@@ -36,10 +36,10 @@ where  import Control.Env.Hierarchical.Internal-  ( Has,+  ( Environment (Super, superL),+    Extends (Extends),+    Has,     Has1,-    Root,-    Super,     getL,     runIF,   )@@ -103,7 +103,6 @@ -- -- @ -- 'deriveEnv' ''Env--- type instance 'Super' Env = 'Root' -- @ -- -- Now, you can inject dependency by specifying the actual value of @Env@@@ -125,7 +124,7 @@  -- $usage:hierarchical -- Instead of resolving the dependency universally,--- you can extend environments by specifying the super environment.+-- you can extend environments by adding @Extend T@ as a field. -- -- In the following example @ExtEnv@ inherits @BaseEnv@. -- The extended environment is a nominal sub-type of its super environment,@@ -138,12 +137,10 @@ -- data BaseEnv = BaseEnv !ServerName !ConnectionPool -- -- 'deriveEnv' ''BaseEnv--- type instance 'Super' BaseEnv = 'Root' ----- data ExtEnv = ExtEnv !BaseEnv !(UserRepo ExtEnv)+-- data ExtEnv = ExtEnv !(Extends BaseEnv) !(UserRepo ExtEnv) -- -- 'deriveEnv' ''ExtEnv--- type instance 'Super' ExtEnv = BaseEnv -- @ -- -- Then, @ExtEnv@ resolves the dependencies.@@ -158,7 +155,7 @@ -- runApp :: ServerName -> ConnectionPool -> [UserName] -> IO () -- runApp serverName pool users = do --   let baseEnv = BaseEnv serverName pool---       extEnv = ExtEnv baseEnv userRepoImpl+--       extEnv = ExtEnv (Extends baseEnv) userRepoImpl --   runRIO extEnv $ do --     printServerName --     forM_ users $ \usernm -> do@@ -214,12 +211,11 @@ -- instance 'Interface' AuthHandler where --   type 'IBase' AuthHandler = RIO ----- data AuthEnv env = AuthEnv !(UserRepo (AutheEnv env)) !env+-- data AuthEnv env = AuthEnv !(UserRepo (AutheEnv env)) !(Extends env) -- 'deriveEnv' ''AuthEnv--- type instance 'Super' (AuthEnv env) = env -- -- authHandlerImpl :: ('Has' ConnectionPool env) => AuthHandler env--- authHandlerImpl = 'mapBaseRIO' (AuthEnv userRepoImpl) handler+-- authHandlerImpl = 'mapBaseRIO' (AuthEnv userRepoImpl . Extends) handler --   where --     handler = AuthHandler signinImpl signupImpl -- @

@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -21,17 +22,18 @@ -- Stability: experimental module Control.Env.Hierarchical.Internal   ( Environment (..),-    Super,+    Extends (..),     Root (..),     Field (..),     Trans (..),-    type (<:),     SomeInterface (SomeInterface),     Has,     Has1,     getL,     ifaceL,     runIF,+    rootL,+    extendsL,   ) where @@ -45,25 +47,44 @@ import Lens.Micro.Mtl (view) import RIO (RIO, runRIO) --- | @Super env@ represents the inheritance relation between environments.--- Every environment must be a descendant of 'Root'.-type family Super env- class Environment env where+  -- | @Super env@ represents the inheritance relation between environments.+  --+  -- * If @env@ owns a field of the form @'Extends' T@, then @T@ is the super environment.+  -- * If @env@ owns no field of the form @'Extends' T@, then 'Root' is the super environment.+  -- * Every @env@ must have at most one field of the form @Extends T@ because multiple inheritance is not supported.+  type Super env+   -- | interfaces that are fields of the environment   type Fields1 env :: [Type -> Type]    -- | fields of the environment   type Fields env :: [Type] +  -- | Lens to super environment+  superL :: Lens' env (Super env)+  {-# INLINE superL #-}+  default superL :: Field (Extends (Super env)) env => Lens' env (Super env)+  superL = fieldL . extendsL+ -- | Root environment that does not have any fields. data Root = Root -type instance Super Root = TypeError ('Text "No super environment for Root")+-- | Wrapper that represents the super environment.+newtype Extends env = Extends env +{-# INLINE extendsL #-}+extendsL :: Lens' (Extends x) x+extendsL f (Extends x) = fmap Extends (f x)++rootL :: Lens' x Root+rootL f x = x <$ f Root+ instance Environment Root where+  type Super Root = TypeError ('Text "No super environment for Root")   type Fields1 Root = '[]   type Fields Root = '[]+  superL = undefined  -- | direct field of @env@ class Field a env where@@ -72,40 +93,53 @@ instance Field env env where   fieldL = id -class Trans a (l :: [Type]) s | a l -> s where-  transL :: Lens' s a+-- Addr s t = '[v1, ... vn]+-- s = v1 <: v2 <: ... <: vn = t+-- s = env1 <: env2 <: env3 = Target s '[env2, env3]+-- s = env1 <: env2 = Target s '[env2]+-- s = env1 = Target s '[]+-- Trans env1 [env1]+class Trans s (l :: [Type]) where+  type Target s l+  transL :: Lens' s (Target s l) -instance Trans a '[] a where+instance Trans s '[] where+  type Target s '[] = s   transL = id -instance (Field s' s, Trans a l s') => Trans a (s : l) s where-  transL = fieldL . transL @a @l+instance (Environment s, Super s ~ t, Trans t l) => Trans s (t : l) where+  type Target s (t : l) = Target t l+  transL = superL . transL @t @l -type family Addr a b :: [Type] where-  Addr a a = '[]-  Addr a b = a : Addr (Super a) b+-- env1 <: env2 <: env3+-- Addr env1 env3 = [env2, env3]+-- Addr env2 env3 = [env3]+-- Addr env3 env3 = []+type family Addr a :: [Type] where+  Addr Root = '[]+  Addr a = Super a ': Addr (Super a)  type family Member (f :: k) (l :: [k]) :: Bool where   Member f '[] = 'False   Member f (f : l) = 'True   Member f (g : l) = Member f l -type family FindEnv (f :: Type) (envs :: [Type]) where-  FindEnv f (env ': envs) = If (Member f (Fields env)) env (FindEnv f envs)-  FindEnv f '[] = TypeError ('Text "No environment has " ':<>: 'ShowType f)--type family FindEnv1 (f :: Type -> Type) (envs :: [Type]) where-  FindEnv1 f (env ': envs) = If (Member f (Fields1 env)) env (FindEnv1 f envs)-  FindEnv1 f '[] = TypeError ('Text "No environment has " ':<>: 'ShowType f)+-- X <- Env1, FindEnv X Env1 [Env2,Root] => []+-- X <- Env2, FindEnv X Env1 [Env2,Root] => [Env2]+type family FindEnv (f :: Type) env (envs :: [Type]) :: [Type] where+  FindEnv f env (env' ': envs) = If (Member f (Fields env)) '[] (env' : FindEnv f env' envs)+  FindEnv f env '[] = TypeError ('Text "No environment has " ':<>: 'ShowType f) -type (<:) env env' = Trans env' (Addr env env') env+type family FindEnv1 (f :: Type -> Type) env (envs :: [Type]) :: [Type] where+  FindEnv1 f env (env' ': envs) = If (Member f (Fields1 env)) '[] (env' : FindEnv1 f env' envs)+  FindEnv1 f env '[] = TypeError ('Text "No environment has " ':<>: 'ShowType f)  data SomeInterface f env where   SomeInterface :: Lens' env' (f env') -> Lens' env env' -> SomeInterface f env -type HasAux a env env' = (env <: env', Field a env')+type HasAux a env route = (Trans env route, Field a (Target env route)) -type Has1Aux f env env' = (env <: env', Field (f env') env')+type Has1Aux f env route = (Trans env route, Field (f (Target env route)) (Target env route))  -- | Type constraint meaning @env@ contains @a@ as a (including ancestors') field. --@@ -113,23 +147,21 @@ -- @Has T env@. If you want to depends on multiple values of the same type, -- please distinguish them by using newtype. type family Has a env where-  Has a env = HasAux a env (FindEnv a (Ancestors env))+  Has a env = HasAux a env (FindEnv a env (Addr env))  -- | Type constraint meaning @env@ contains @f env'@ for some ancestor @env'@ type family Has1 f env where-  Has1 f env = Has1Aux f env (FindEnv1 f (Ancestors env))--type Ancestors env = Addr env Root--inheritL :: forall env env'. env <: env' => Lens' env env'-inheritL = transL @env' @(Addr env env')+  Has1 f env = Has1Aux f env (FindEnv1 f env (Addr env))  -- | Lens to extract @a@ from @env@ getL :: forall a env. Has a env => Lens' env a-getL = inheritL @env @(FindEnv a (Ancestors env)) . fieldL+getL = transL @env @(FindEnv a env (Addr env)) . fieldL  ifaceL :: forall f env. Has1 f env => SomeInterface f env-ifaceL = SomeInterface (fieldL @(f (FindEnv1 f (Ancestors env)))) inheritL+ifaceL =+  SomeInterface+    (fieldL @(f (Target env (FindEnv1 f env (Addr env)))))+    (transL @env @(FindEnv1 f env (Addr env)))  -- | Run action that depends on an interface @f@. -- The action must be polymorphic to @env'@,@@ -137,7 +169,7 @@ runIF :: forall f env a. Has1 f env => (forall env'. f env' -> RIO env' a) -> RIO env a runIF body =   case ifaceL @f of-    SomeInterface _ifaceL superL -> do-      iface <- view $ superL . _ifaceL-      env <- view superL+    SomeInterface _ifaceL _superL -> do+      iface <- view $ _superL . _ifaceL+      env <- view _superL       runRIO env (body iface)

@@ -10,10 +10,13 @@ module Control.Env.Hierarchical.TH (deriveEnv) where  import Control.Env.Hierarchical.Internal-  ( Environment (Fields, Fields1),+  ( Environment (Fields, Fields1, Super, superL),+    Extends,     Field (fieldL),+    Root,+    rootL,   )-import Control.Monad (filterM, zipWithM)+import Control.Monad (filterM, guard, zipWithM) import Data.Function ((&)) import Language.Haskell.TH   ( Dec (TySynD),@@ -44,44 +47,16 @@     promotedConsT,     promotedNilT,     reify,+    reportError,     reportWarning,     tySynEqn,     tySynInstD,+    valD,     varE,     varP,   ) import qualified Language.Haskell.TH.Datatype as D--{--data Env f a b = Env {-    _x :: Int,-    _y :: a,-    _z :: Obj Env,-    _w :: Obj2 b Env-    _v :: f Env--}-deriveEnvironment ''Env-==>-instance Environment (Env f a b) where-    type Fields (Env f a b) = '[Env f a b, Int, a,Obj Env, Obj2 b Env, f Env]-    type Fields1 (Env f a b) = '[Obj, Obj2 b, f]--instance Field Int (Env f a b) where-  fieldL = x--instance Field a (Env f a b) where-  fieldL = y--instance Field (Obj Env) (Env f a b) where-  fieldL = z--instance Field (Obj2 b Env) (Env f a b) where-  fieldL = w--instance Field (f Env) (Env f a b) where-  fieldL = v--}+import Language.Haskell.TH.Ppr (commaSep)  deriveEnv :: Name -> Q [Dec] deriveEnv envName = do@@ -139,7 +114,7 @@     envTypeQ = pure envType     -- envType = D.datatypeType info     decs :: [DecQ]-    decs = [fieldsDec, fields1Dec]+    decs = [fieldsDec, fields1Dec, superDec] ++ [superLDec | null extendsT]     -- tyVars = D.datatypeVars info     -- type Fields ($envName $typeVars) = '[$field1 ... $field2]     fieldsDec = tySynInstD (tySynEqn (Just tyVars) lhs rhs)@@ -151,6 +126,26 @@       where         lhs = conT ''Fields1 `appT` envTypeQ         rhs = promotedListT =<< fields1 envType consInfo++    -- Super ($envName $typeVars) = $t+    -- where @$Extends $t@ is a field of the environment+    superDec = tySynInstD (tySynEqn (Just tyVars) lhs rhs)+      where+        lhs = conT ''Super `appT` envTypeQ+        rhs = case extendsT of+          [t] -> pure t+          [] -> conT ''Root+          ts@(t : _) -> do+            reportError $ "Multiple inheritance is not allowed: " <> show (commaSep ts)+            pure t+    extendsT :: [Type]+    extendsT = do+      AppT (ConT conName) t <- D.constructorFields consInfo+      guard $ conName == ''Extends+      pure t++    -- superL = rootL (only if @Super ($envName $typeVars) = Root@)+    superLDec = valD (varP 'superL) (normalB (varE 'rootL)) []  fields1 :: Type -> D.ConstructorInfo -> Q [Type] fields1 ty consInfo =

@@ -1,6 +1,8 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -8,13 +10,17 @@ module Control.Env.Hierarchical.InternalSpec where  import Control.Env.Hierarchical.Internal-  ( Environment (Fields, Fields1),+  ( Environment (Fields, Fields1, superL),+    Extends (Extends),     Field (fieldL),-    Root,+    Has,+    Root (Root),     Super,     getL,     runIF,   )+import Control.Method (Interface (IBase), mapBaseRIO)+import GHC.Generics (Generic) import Lens.Micro.Mtl (view) import Lens.Micro.TH (makeLenses) import RIO (RIO, runRIO)@@ -40,6 +46,9 @@ newtype Param2 = Param2 Int   deriving (Eq, Show) +newtype Param3 = Param3 Int+  deriving (Eq, Show)+ data Env1 = Env1   { _obj1 :: Obj1 Env1,     _param1 :: Param1@@ -48,7 +57,7 @@ makeLenses ''Env1  data Env2 = Env2-  { _env1 :: Env1,+  { _env1 :: Extends Env1,     _obj2 :: Obj2 Env2,     _param2 :: Param2   }@@ -58,17 +67,13 @@ instance Environment Env1 where   type Fields1 Env1 = '[Obj1]   type Fields Env1 = '[Env1, Obj1 Env1, Param1]--type instance Super Env1 = Root+  type Super Env1 = Root+  superL f x = x <$ f Root  instance Environment Env2 where   type Fields1 Env2 = '[Obj2]-  type Fields Env2 = '[Env2, Env1, Obj2 Env2, Param2]--type instance Super Env2 = Env1--instance Field Env1 Env1 where-  fieldL = id+  type Fields Env2 = '[Extends Env1, Obj2 Env2, Param2]+  type Super Env2 = Env1  instance Field (Obj1 Env1) Env1 where   fieldL = obj1@@ -76,10 +81,7 @@ instance Field Param1 Env1 where   fieldL = param1 -instance Field Env2 Env2 where-  fieldL = id--instance Field Env1 Env2 where+instance Field (Extends Env1) Env2 where   fieldL = env1  instance Field (Obj2 Env2) Env2 where@@ -111,9 +113,35 @@             _method4 = pure 4           },       _param2 = Param2 2,-      _env1 = env1Impl+      _env1 = Extends env1Impl     } +data Env3 env = Env3 Param3 (Extends env)++instance Environment (Env3 env) where+  type Fields (Env3 env) = '[Param3]+  type Fields1 (Env3 env) = '[]+  type Super (Env3 env) = env++instance Field (Extends env) (Env3 env) where+  fieldL f (Env3 x1 x2) = fmap (\y2 -> Env3 x1 y2) (f x2)++instance Field Param3 (Env3 env) where+  fieldL f (Env3 x1 x2) = fmap (\y1 -> Env3 y1 x2) (f x1)++newtype Obj3 env = Obj3 {_runObj3 :: RIO env Int}+  deriving (Generic)++instance Interface Obj3 where+  type IBase Obj3 = RIO++obj3Impl :: Has Param1 env => Obj3 env+obj3Impl = mapBaseRIO (Env3 (Param3 3) . Extends) $+  Obj3 $ do+    Param3 n <- view getL+    Param1 m <- view getL+    pure $ n + m+ spec :: Spec spec = do   describe "getL" $ do@@ -158,3 +186,7 @@       n <- runRIO env2Impl $ do         runIF @Obj2 _method3       n `shouldBe` 3+    it "runIF @Obj3 from Env1" $ do+      n <- runRIO env1Impl $ do+        _runObj3 obj3Impl+      n `shouldBe` 4

@@ -11,6 +11,7 @@  import Control.Env.Hierarchical.Internal   ( Environment (Fields, Fields1),+    Extends,     Field (fieldL),     Root,     Super,@@ -45,12 +46,18 @@  deriveEnv ''Env -type instance Super (Env f a) = Root+newtype Param1 = Param1 Int +data Env2 = Env2 (Extends E) Param1++deriveEnv ''Env2+ spec :: Spec spec = describe "deriveEnv" $ do   it "`Super E` is Root" $ do     typeRep (Proxy @(Super E)) `shouldBe` typeRep (Proxy @Root)+  it "`Super Env2` is E" $ do+    typeRep (Proxy @(Super Env2)) `shouldBe` typeRep (Proxy @E)   it "`Fields E` is '[E, Int, Bool, Maybe E, Either Int E, F E]" $ do     typeRep (Proxy @(Fields E))       `shouldBe` typeRep (Proxy @'[E, Int, Bool, Maybe E, Either Int E, F E])

@@ -10,14 +10,13 @@ module Control.Env.HierarchicalSpec where  import Control.Env.Hierarchical-  ( Has,+  ( Extends (Extends),+    Has,     Has1,-    Root,     deriveEnv,     getL,     runIF,   )-import Control.Env.Hierarchical.Internal (Super) import Control.Method (Interface (IBase), mapBaseRIO) import Lens.Micro.TH (makeLenses) import RIO@@ -36,11 +35,11 @@   }  data Env2 = Env2-  { env1 :: Env1,+  { env1 :: Extends Env1,     foo :: FooObj Env2   } -data Env3 env = Env3 env Param2+data Env3 env = Env3 (Extends env) Param2  data HogeObj env = HogeObj   { _hogeMethod :: Int -> RIO env Text,@@ -67,12 +66,6 @@ deriveEnv ''Env2 deriveEnv ''Env3 -type instance Super Env1 = Root--type instance Super Env2 = Env1--type instance Super (Env3 env) = env- example1 :: (Has1 HogeObj env, Has Param1 env) => RIO env Text example1 = do   Param1 n <- view getL@@ -92,11 +85,11 @@ mkEnv2 =   Env2     { foo = mapBaseRIO mkEnv3 fooImpl,-      env1 = mkEnv1+      env1 = Extends mkEnv1     }  mkEnv3 :: env -> Env3 env-mkEnv3 env = Env3 env (Param2 5)+mkEnv3 env = Env3 (Extends env) (Param2 5)  hogeImpl :: HogeObj env hogeImpl =