diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hierarchical-env + +## 0.1.0.0 -- 2021-04-22 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# hierarchical-env +![Haskell CI](https://github.com/autotaker/hierarchical-env/workflows/Haskell%20CI/badge.svg) + + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hierarchical-env.cabal b/hierarchical-env.cabal new file mode 100644 --- /dev/null +++ b/hierarchical-env.cabal @@ -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 diff --git a/src/Control/Env/Hierarchical.hs b/src/Control/Env/Hierarchical.hs new file mode 100644 --- /dev/null +++ b/src/Control/Env/Hierarchical.hs @@ -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@ diff --git a/src/Control/Env/Hierarchical/Internal.hs b/src/Control/Env/Hierarchical/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Env/Hierarchical/Internal.hs @@ -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) diff --git a/src/Control/Env/Hierarchical/TH.hs b/src/Control/Env/Hierarchical/TH.hs new file mode 100644 --- /dev/null +++ b/src/Control/Env/Hierarchical/TH.hs @@ -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 diff --git a/test/Control/Env/Hierarchical/InternalSpec.hs b/test/Control/Env/Hierarchical/InternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Env/Hierarchical/InternalSpec.hs @@ -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 diff --git a/test/Control/Env/Hierarchical/THSpec.hs b/test/Control/Env/Hierarchical/THSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Env/Hierarchical/THSpec.hs @@ -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 diff --git a/test/Control/Env/HierarchicalSpec.hs b/test/Control/Env/HierarchicalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Env/HierarchicalSpec.hs @@ -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" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists -F -pgmF hspec-discover #-}