packages feed

hierarchical-env (empty) → 0.1.0.0

raw patch · 12 files changed

+1013/−0 lines, 12 filesdep +basedep +hierarchical-envdep +hspecsetup-changed

Dependencies added: base, hierarchical-env, hspec, method, microlens, microlens-mtl, microlens-th, rio, template-haskell, th-abstraction

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for hierarchical-env++## 0.1.0.0 -- 2021-04-22++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, Taku Terao++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 autotaker 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
@@ -0,0 +1,5 @@+# hierarchical-env+![Haskell CI](https://github.com/autotaker/hierarchical-env/workflows/Haskell%20CI/badge.svg)+++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hierarchical-env.cabal view
@@ -0,0 +1,71 @@+cabal-version:      2.4++-- Initial package description 'hierarchical-env.cabal' generated by 'cabal+-- init'.  For further documentation, see+-- http://haskell.org/cabal/users-guide/++name:               hierarchical-env+version:            0.1.0.0+synopsis:           hierarchical environments for dependency injection++description:        This library provides scalable dependency injection for RIO monad+homepage:           https://github.com/autotaker/hierarchical-env++-- bug-reports:+license:            BSD-3-Clause+license-file:       LICENSE+author:             Taku Terao+maintainer:         autotaker@gmail.com++-- copyright:+category: Control+extra-source-files:+  CHANGELOG.md+  README.md++common shared-properties+  build-depends:+    , base              >=4        && <5+    , method            ^>=0.3.1.0+    , microlens         ^>=0.4+    , microlens-mtl     ^>=0.2+    , microlens-th      ^>=0.4+    , rio               >=0.1.16.0+    , template-haskell  >=2.15 && < 2.18+    , th-abstraction    ^>=0.4.2.0++  default-language: Haskell2010+  ghc-options:+    -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates+    -Wmissing-import-lists -Wcompat++common test-depends+  build-depends:      hspec ^>=2.7.4+  build-tool-depends: hspec-discover:hspec-discover -any++library+  import:          shared-properties++  -- cabal-fmt: expand src+  exposed-modules:+    Control.Env.Hierarchical+    Control.Env.Hierarchical.Internal+    Control.Env.Hierarchical.TH++  -- other-modules:+  -- other-extensions:+  hs-source-dirs:  src++test-suite hierarchical-env-test+  import:         shared-properties, test-depends+  type:           exitcode-stdio-1.0+  hs-source-dirs: test+  main-is:        Spec.hs++  -- cabal-fmt: expand test -Spec+  other-modules:+    Control.Env.Hierarchical.InternalSpec+    Control.Env.Hierarchical.THSpec+    Control.Env.HierarchicalSpec++  build-depends:  hierarchical-env
+ src/Control/Env/Hierarchical.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE ExplicitNamespaces #-}++-- |+-- Module : Control.Env.Hierarchical+-- Description:+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Control.Env.Hierarchical+  ( -- * Getting Fields+    -- $usage:field+    Has,+    getL,++    -- * Invoking interface methods+    -- $usage:interface+    Has1,+    runIF,++    -- * Injecting dependecies++    -- ** With universal environments+    -- $usage:dependency++    -- ** With hierarchical environments+    -- $usage:hierarchical+    Root,+    Super,+    deriveEnv,++    -- * Hiding dependencies+    -- $usage:hiding+    Interface (..),+    mapBaseRIO,+  )+where++import Control.Env.Hierarchical.Internal+  ( Has,+    Has1,+    Root,+    Super,+    getL,+    runIF,+  )+import Control.Env.Hierarchical.TH (deriveEnv)+import Control.Method (Interface (IBase, mapBase), mapBaseRIO)++-- $usage:field+--+-- If a method depends on some value of type @T@,+-- use @'Has' T env@ constraints, and get the value from the environment+-- with @view 'getL'@.+--+--+-- @+-- newtype ServerName = ServerName String+-- printServerName :: ('Has' ServerName env) => RIO env ()+-- printServerName = do+--   ServerName n <- view 'getL'+--   liftIO $ putStrLn $ "ServerName is " <> n+-- @++-- $usage:interface+-- We call a record type whose fields are methods as an interface.+--+-- In the following example, @UserRepo@ is an interface.+--+-- Dependency to an interface @F@ is represented as type constraint @Has1 F env@,+-- methods of the interface can be invoked inside @'runIF'@.+--+-- @+-- data UserRepo env = UserRepo {+--   _createUser :: UserName -> RIO env UserId,+--   _setPassword :: UserId -> Password -> RIO env ()+-- }+-- makeLenses ''UserRepo+--+-- data User = User {+--   _userName :: UserName,+--   _userId :: UserId,+-- } deriving(Eq, Ord, Show)+-- makeLenses ''User+--+-- signup :: ('Has1' UserRepo env) => UserName -> Password -> RIO env User+-- signup name passwd = 'runIF' $ \\userRepo -> do+--   userId <- view createUser userRepo name+--   view setPassword userRepo userId passwd+--   pure User { _userName = name, _userId = userId}+-- @++-- $usage:dependency+--+-- First, define environment @Env@ that+-- contains all dependencies as fields.+--+-- @+-- data Env = Env !ServerName !(UserRepo Env)+-- @+--+-- Then, the following boilerpolate will derive required type constraints.+-- (e.g. @'Has' ServerName Env@, @'Has1' UserRepo Env@)+--+-- @+-- 'deriveEnv' ''Env+-- type instance 'Super' Env = 'Root'+-- @+--+-- Now, you can inject dependency by specifying the actual value of @Env@+-- to the argument of 'runRIO'.+--+-- @+-- mkUserRepo :: DBConfig -> UserRepo Env+-- mkUserRepo = ...+--+-- runApp :: ServerName -> DBConfig -> [UserName] -> IO ()+-- runApp serverName dbConfig users = do+--   let env = Env serverName (mkUserRepo dbConfig)+--   runRIO env $ do+--     printServerName+--     forM_ users $ \userName ->+--       user <- signup userName "password"+--       print user+-- @++-- $usage:hierarchical+-- Instead of resolving the dependency universally,+-- you can extend environments by specifying the super environment.+--+-- In the following example @ExtEnv@ inherits @BaseEnv@.+-- The extended environment is a nominal sub-type of its super environment,+-- that is,+--+-- * @'Has' T ('Super' E)@ implies @'Has' T E@, and+-- * @'Has1' F ('Super' E)@ implies @'Has1' F E@.+--+-- @+-- data BaseEnv = BaseEnv !ServerName !ConnectionPool+--+-- 'deriveEnv' ''BaseEnv+-- type instance 'Super' BaseEnv = 'Root'+--+-- data ExtEnv = ExtEnv !BaseEnv !(UserRepo ExtEnv)+--+-- 'deriveEnv' ''ExtEnv+-- type instance 'Super' ExtEnv = BaseEnv+-- @+--+-- Then, @ExtEnv@ resolves the dependencies.+--+-- @+-- userRepoImpl :: 'Has' ConnectionPool env => UserRepo env+-- userRepoImpl = UserRepo createUserImpl setPaswordImpl+--   where+--   createUserImpl userName = ...+--   setPasswordImpl uid passwd = ...+--+-- runApp :: ServerName -> ConnectionPool -> [UserName] -> IO ()+-- runApp serverName pool users = do+--   let baseEnv = BaseEnv serverName pool+--       extEnv = ExtEnv baseEnv userRepoImpl+--   runRIO extEnv $ do+--     printServerName+--     forM_ users $ \usernm -> do+--       user <- signup usernm "password"+--       liftIO $ print user+-- @++-- $usage:hiding+-- Suppose that we are implementing an interface @AuthHandler@,+-- which handle signin and signup business logic.+--+-- @+-- data AuthHandler env = AuthHandler {+--   _signin :: UserName -> Password -> RIO env User+--   _signup :: UserName -> Password -> RIO env User+-- }+-- makeLenses ''AuthHandler+-- @+--+-- The @authHandlerImpl@ depends on another interface @UserRepo@,+-- which accesses a database to store user information.+--+-- @+-- data UserRepo env = UserRepo {+--  _createUser :: UserName -> RIO env UserId,+--  _setPassword :: UserId -> Password -> RIO env ()+-- }+-- makeLenses ''UserRepo+--+-- userRepoImpl :: (Has ConnectionPool env) => UserRepo env+-- userRepoImpl = ...+--+-- authHandlerImpl :: ('Has1' UserRepo env) => AuthHandler env+-- authHandlerImpl = AuthHandler signinImpl signupImpl+--+-- signupImpl :: (Has1 UserRepo env) => UserName -> Password -> RIO env User+-- signupImpl usernm passwd = ...+--+-- signinImpl :: (Has1 UserRepo env) => UserName -> Password -> RIO env User+-- signinImpl usernm passwd = ...+-- @+--+--+-- Assume that @UserRepo@ is a private interface and should not be exported.+-- Let's refactor @authHandlerImpl@ by using 'mapBaseRIO'.+--+-- @+-- data AuthHandler env = AuthHandler {+--   _signin :: UserName -> Password -> RIO env User+--   _signup :: UserName -> Password -> RIO env User+-- } deriving(Generic)+--+-- instance 'Interface' AuthHandler where+--   type 'IBase' AuthHandler = RIO+--+-- data AuthEnv env = AuthEnv !(UserRepo (AutheEnv env)) !env+-- 'deriveEnv' ''AuthEnv+-- type instance 'Super' (AuthEnv env) = env+--+-- authHandlerImpl :: ('Has' ConnectionPool env) => AuthHandler env+-- authHandlerImpl = 'mapBaseRIO' (AuthEnv userRepoImpl) handler+--   where+--     handler = AuthHandler signinImpl signupImpl+-- @+--+-- Now, the dependency to @UserRepo@ is resolved in the module+-- and hidden from the signature of @authHandlerImpl@
+ src/Control/Env/Hierarchical/Internal.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : Control.Env.Hierarchical.Internal+-- Description:+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Control.Env.Hierarchical.Internal+  ( Environment (..),+    Super,+    Root (..),+    Field (..),+    Trans (..),+    type (<:),+    SomeInterface (SomeInterface),+    Has,+    Has1,+    getL,+    ifaceL,+    runIF,+  )+where++import Data.Kind (Type)+import Data.Type.Bool (If)+import GHC.TypeLits+  ( ErrorMessage (ShowType, Text, (:<>:)),+    TypeError,+  )+import Lens.Micro (Lens')+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+  -- | interfaces that are fields of the environment+  type Fields1 env :: [Type -> Type]++  -- | fields of the environment+  type Fields env :: [Type]++-- | Root environment that does not have any fields.+data Root = Root++type instance Super Root = TypeError ('Text "No super environment for Root")++instance Environment Root where+  type Fields1 Root = '[]+  type Fields Root = '[]++-- | direct field of @env@+class Field a env where+  fieldL :: Lens' env a++instance Field env env where+  fieldL = id++class Trans a (l :: [Type]) s | a l -> s where+  transL :: Lens' s a++instance Trans a '[] a where+  transL = id++instance (Field s' s, Trans a l s') => Trans a (s : l) s where+  transL = fieldL . transL @a @l++type family Addr a b :: [Type] where+  Addr a a = '[]+  Addr a b = a : Addr (Super a) b++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)++type (<:) env env' = Trans env' (Addr env env') env++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 Has1Aux f env env' = (env <: env', Field (f env') env')++-- | Type constraint meaning @env@ contains @a@ as a (including ancestors') field.+--+-- An environment @env@ contains unique value for each type @T@ that satisfies+-- @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))++-- | 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')++-- | Lens to extract @a@ from @env@+getL :: forall a env. Has a env => Lens' env a+getL = inheritL @env @(FindEnv a (Ancestors env)) . fieldL++ifaceL :: forall f env. Has1 f env => SomeInterface f env+ifaceL = SomeInterface (fieldL @(f (FindEnv1 f (Ancestors env)))) inheritL++-- | Run action that depends on an interface @f@.+-- The action must be polymorphic to @env'@,+-- because it will run in some ancestor environment, which may be different from @env@,+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+      runRIO env (body iface)
+ src/Control/Env/Hierarchical/TH.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Control.Env.Hierarchical.TH+-- Description:+-- License: BSD-3+-- Maintainer: autotaker@gmail.com+-- Stability: experimental+module Control.Env.Hierarchical.TH (deriveEnv) where++import Control.Env.Hierarchical.Internal+  ( Environment (Fields, Fields1),+    Field (fieldL),+  )+import Control.Monad (filterM, zipWithM)+import Data.Function ((&))+import Language.Haskell.TH+  ( Dec (TySynD),+    DecQ,+    Info (TyConI),+    Inline (Inline),+    Name,+    Phases (AllPhases),+    Q,+    RuleMatch (FunLike),+    TyVarBndr,+    Type (AppT, ConT),+    TypeQ,+    appE,+    appT,+    clause,+    conE,+    conP,+    conT,+    cxt,+    funD,+    instanceD,+    lam1E,+    mkName,+    normalB,+    pprint,+    pragInlD,+    promotedConsT,+    promotedNilT,+    reify,+    reportWarning,+    tySynEqn,+    tySynInstD,+    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+-}++deriveEnv :: Name -> Q [Dec]+deriveEnv envName = do+  envInfo <- D.reifyDatatype envName+  consInfo <- case D.datatypeCons envInfo of+    [consInfo] -> pure consInfo+    _ -> fail "Multiple costructors"+  let envType = D.datatypeType envInfo+      tyVars = D.datatypeVars envInfo+      fields = D.constructorFields consInfo+  dec <- envInstance (envType, consInfo, tyVars)+  decs <-+    zipWithM+      (deriveField (consInfo, envType))+      fields+      [0 ..]+  pure (dec : decs)++-- instance Field $ty $env where+--   $(deriveLens ...)+deriveField :: (D.ConstructorInfo, Type) -> Type -> Int -> Q Dec+deriveField (conInfo, envType) fieldType fieldIdx =+  instanceD (cxt []) fieldInstType [inlineDec, dec]+  where+    fieldInstType =+      conT ''Field `appT` pure fieldType `appT` pure envType+    -- fieldL = l where $(makeLensesFor ...)+    inlineDec = pragInlD 'fieldL Inline FunLike AllPhases+    dec = deriveLens conInfo 'fieldL fieldIdx++-- $lname f ($con x_1 ... x_n)= fmap (\y_$idx -> $con x_1 ... y_idx ... x_n) (f x_$idx)++deriveLens :: D.ConstructorInfo -> Name -> Int -> Q Dec+deriveLens conInfo lname idx = funD lname [clause argsP (normalB bodyE) []]+  where+    argsP = [varP f, conP conName conArgsP]+    conName = D.constructorName conInfo+    conArgsP = map varP args+    bodyE = varE 'fmap `appE` setterE `appE` appE (varE f) (varE x_idx)+    setterE = lam1E (varP y) (foldl appE (conE conName) argsE)+    argsE = [varE $ if i == idx then y else x | (x, i) <- zip args [0 ..]]+    f = mkName "f"+    y = mkName "y"+    x_idx = args !! idx+    args = [mkName ("x_" ++ show i) | i <- [1 .. arity]]+    arity = length $ D.constructorFields conInfo++envInstance :: (Type, D.ConstructorInfo, [TyVarBndr]) -> DecQ+envInstance (envType, consInfo, tyVars) =+  instanceD (cxt []) envInstType decs+  where+    -- instance Environment $envName where+    --   $decs+    envInstType = conT ''Environment `appT` envTypeQ+    envTypeQ = pure envType+    -- envType = D.datatypeType info+    decs :: [DecQ]+    decs = [fieldsDec, fields1Dec]+    -- tyVars = D.datatypeVars info+    -- type Fields ($envName $typeVars) = '[$field1 ... $field2]+    fieldsDec = tySynInstD (tySynEqn (Just tyVars) lhs rhs)+      where+        lhs = conT ''Fields `appT` envTypeQ+        rhs = promotedListT (envType : D.constructorFields consInfo)+    -- type Fields1 ($envName $typeVars) = '[$obj1 ... $obj2]+    fields1Dec = tySynInstD (tySynEqn (Just tyVars) lhs rhs)+      where+        lhs = conT ''Fields1 `appT` envTypeQ+        rhs = promotedListT =<< fields1 envType consInfo++fields1 :: Type -> D.ConstructorInfo -> Q [Type]+fields1 ty consInfo =+  [f | AppT f x <- D.constructorFields consInfo, x == ty]+    & filterM headIsNotTypeSynonym+  where+    headIsNotTypeSynonym _ty = go _ty+      where+        go (AppT ty' _) = go ty'+        go (ConT name) = do+          r <- reify name+          case r of+            TyConI TySynD {} -> do+              reportWarning ("Skipping type synonym field1: " ++ pprint _ty ++ ". Please use newtype")+              pure False+            _ -> pure True+        go _ = pure True++promotedListT :: [Type] -> TypeQ+promotedListT =+  foldr (appT . appT promotedConsT . pure) promotedNilT++-- type Fields ($envName $typeVars) = $fields
+ test/Control/Env/Hierarchical/InternalSpec.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++module Control.Env.Hierarchical.InternalSpec where++import Control.Env.Hierarchical.Internal+  ( Environment (Fields, Fields1),+    Field (fieldL),+    Root,+    Super,+    getL,+    runIF,+  )+import Lens.Micro.Mtl (view)+import Lens.Micro.TH (makeLenses)+import RIO (RIO, runRIO)+import Test.Hspec (Spec, describe, it, shouldBe)++data Obj1 env = Obj1+  { _method1 :: RIO env Int,+    _method2 :: RIO env Int+  }++makeLenses ''Obj1++data Obj2 env = Obj2+  { _method3 :: RIO env Int,+    _method4 :: RIO env Int+  }++makeLenses ''Obj2++newtype Param1 = Param1 Int+  deriving (Eq, Show)++newtype Param2 = Param2 Int+  deriving (Eq, Show)++data Env1 = Env1+  { _obj1 :: Obj1 Env1,+    _param1 :: Param1+  }++makeLenses ''Env1++data Env2 = Env2+  { _env1 :: Env1,+    _obj2 :: Obj2 Env2,+    _param2 :: Param2+  }++makeLenses ''Env2++instance Environment Env1 where+  type Fields1 Env1 = '[Obj1]+  type Fields Env1 = '[Env1, Obj1 Env1, Param1]++type instance Super Env1 = 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++instance Field (Obj1 Env1) Env1 where+  fieldL = obj1++instance Field Param1 Env1 where+  fieldL = param1++instance Field Env2 Env2 where+  fieldL = id++instance Field Env1 Env2 where+  fieldL = env1++instance Field (Obj2 Env2) Env2 where+  fieldL = obj2++instance Field Param2 Env2 where+  fieldL = param2++env1Impl :: Env1+env1Impl =+  Env1+    { _obj1 =+        Obj1+          { _method1 = pure 1,+            _method2 = pure 2+          },+      _param1 = Param1 1+    }++env2Impl :: Env2+env2Impl =+  Env2+    { _obj2 =+        Obj2+          { _method3 = do+              x <- runIF _method1+              y <- runIF _method2+              pure $ x + y,+            _method4 = pure 4+          },+      _param2 = Param2 2,+      _env1 = env1Impl+    }++spec :: Spec+spec = do+  describe "getL" $ do+    it "getL @(Obj1 Env1) from Env1" $ do+      n <- runRIO env1Impl $ do+        x <- view (getL @(Obj1 Env1))+        _method1 x+      n `shouldBe` 1+    it "getL @Param1 from Env1" $ do+      n <- runRIO env1Impl $ do+        view (getL @Param1)+      n `shouldBe` Param1 1+    it "getL @(Obj1 Env1) from Env2" $ do+      n <- runRIO env2Impl $ do+        x <- view (getL @(Obj1 Env1))+        env <- view (getL @Env1)+        runRIO env $ _method1 x+      n `shouldBe` 1+    it "getL @Param1 from Env1" $ do+      n <- runRIO env2Impl $ do+        view (getL @Param1)+      n `shouldBe` Param1 1+    it "getL @(Obj2 Env2) from Env2" $ do+      n <- runRIO env2Impl $ do+        x <- view (getL @(Obj2 Env2))+        _method3 x+      n `shouldBe` 3+    it "getL @Param2 from Env2" $ do+      n <- runRIO env2Impl $ do+        view (getL @Param2)+      n `shouldBe` Param2 2+  describe "runIF" $ do+    it "runIF @Obj1 from Env1" $ do+      n <- runRIO env1Impl $ do+        runIF @Obj1 _method1+      n `shouldBe` 1+    it "runIF @Obj1 from Env2" $ do+      n <- runRIO env2Impl $ do+        runIF @Obj1 _method1+      n `shouldBe` 1+    it "runIF @Obj2 from Env2" $ do+      n <- runRIO env2Impl $ do+        runIF @Obj2 _method3+      n `shouldBe` 3
+ test/Control/Env/Hierarchical/THSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}++--{-# OPTIONS_GHC -ddump-splices -ddump-to-file #-}++module Control.Env.Hierarchical.THSpec where++import Control.Env.Hierarchical.Internal+  ( Environment (Fields, Fields1),+    Field (fieldL),+    Root,+    Super,+  )+import Control.Env.Hierarchical.TH (deriveEnv)+import Data.Maybe (isNothing)+import Data.Typeable (Proxy (Proxy), typeRep)+import Lens.Micro (to, (^.), (^?), _Left)+import Test.Hspec (Spec, describe, it, shouldBe)++type F env = (env -> Int)++data Env f a = Env+  { _x :: a,+    _y :: Bool,+    _z :: Maybe (Env f a),+    _w :: f a (Env f a),+    _v :: F (Env f a) -- Type Synonym is not allowed for Field1+  }++type E = Env Either Int++mkEnv :: E+mkEnv =+  Env+    { _x = 0,+      _y = True,+      _z = Nothing,+      _w = Left 0,+      _v = const 0+    }++deriveEnv ''Env++type instance Super (Env f a) = Root++spec :: Spec+spec = describe "deriveEnv" $ do+  it "`Super E` is Root" $ do+    typeRep (Proxy @(Super E)) `shouldBe` typeRep (Proxy @Root)+  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])+  it "`Fields1 E` is '[Maybe, Either Int]" $ do+    typeRep (Proxy @(Fields1 E)) `shouldBe` typeRep (Proxy @'[Maybe, Either Int])++  it "Field E E is defined" $ do+    _x (mkEnv ^. fieldL @E) `shouldBe` (0 :: Int)+  it "Field Int E is defined" $ do+    (mkEnv ^. fieldL @Int) `shouldBe` (0 :: Int)+  it "Field Bool E is defined" $ do+    (mkEnv ^. fieldL @Bool) `shouldBe` True+  it "Field (Maybe E) E is defined" $ do+    (mkEnv ^. fieldL @(Maybe E) . to isNothing) `shouldBe` True+  it "Field (Either Int E) is defined" $ do+    (mkEnv ^? fieldL @(Either Int E) . _Left) `shouldBe` Just 0
+ test/Control/Env/HierarchicalSpec.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Control.Env.HierarchicalSpec where++import Control.Env.Hierarchical+  ( 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+  ( Display (textDisplay),+    Generic,+    RIO,+    Text,+    runRIO,+    view,+  )+import Test.Hspec (Spec, it, shouldReturn)++data Env1 = Env1+  { hoge :: HogeObj Env1,+    param1 :: Param1+  }++data Env2 = Env2+  { env1 :: Env1,+    foo :: FooObj Env2+  }++data Env3 env = Env3 env Param2++data HogeObj env = HogeObj+  { _hogeMethod :: Int -> RIO env Text,+    _fugaMethod :: Bool -> RIO env Bool+  }++data FooObj env = FooObj+  { _fooMethod :: RIO env Text,+    _barMethod :: RIO env Bool+  }+  deriving (Generic)++instance Interface FooObj where+  type IBase FooObj = RIO++newtype Param1 = Param1 Int++newtype Param2 = Param2 Int++makeLenses ''HogeObj+makeLenses ''FooObj++deriveEnv ''Env1+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+  runIF (\x -> view hogeMethod x n)++example2 :: (Has1 FooObj env) => RIO env Text+example2 = runIF _fooMethod++mkEnv1 :: Env1+mkEnv1 =+  Env1+    { hoge = hogeImpl,+      param1 = Param1 10+    }++mkEnv2 :: Env2+mkEnv2 =+  Env2+    { foo = mapBaseRIO mkEnv3 fooImpl,+      env1 = mkEnv1+    }++mkEnv3 :: env -> Env3 env+mkEnv3 env = Env3 env (Param2 5)++hogeImpl :: HogeObj env+hogeImpl =+  HogeObj+    { _hogeMethod = pure . textDisplay,+      _fugaMethod = pure . not+    }++--+fooImpl :: (Has1 HogeObj env, Has Param2 env) => FooObj env+fooImpl =+  FooObj+    { _fooMethod = do+        Param2 n <- view getL+        runIF (\x -> view hogeMethod x n),+      _barMethod = pure True+    }++spec :: Spec+spec = do+  it "" $ do+    runRIO mkEnv1 example1 `shouldReturn` "10"+  it "" $ do+    runRIO mkEnv2 example2 `shouldReturn` "5"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -Wno-missing-import-lists -F -pgmF hspec-discover #-}