mockcat 0.3.1.0 → 0.4.0.0
raw patch · 9 files changed
+624/−187 lines, 9 filesdep +transformersPVP ok
version bump matches the API change (PVP)
Dependencies added: transformers
API changes (from Hackage documentation)
+ Test.MockCat.TH: instance GHC.Classes.Eq Test.MockCat.TH.MockType
+ Test.MockCat.TH: makePartialMock :: Q Type -> Q [Dec]
+ Test.MockCat.TH: makePartialMockWithOptions :: Q Type -> MockOptions -> Q [Dec]
Files
- README.md +44/−1
- mockcat.cabal +7/−1
- src/Test/MockCat/MockT.hs +1/−0
- src/Test/MockCat/TH.hs +284/−185
- test/Spec.hs +4/−0
- test/Test/MockCat/Definition.hs +27/−0
- test/Test/MockCat/Impl.hs +29/−0
- test/Test/MockCat/PartialMockSpec.hs +125/−0
- test/Test/MockCat/PartialMockTHSpec.hs +103/−0
README.md view
@@ -38,7 +38,7 @@ readFile :: FilePath -> m Text writeFile :: FilePath -> Text -> m () -operationProgram :: FileOperation m => FileOperation m+operationProgram :: FileOperation m => FilePath -> FilePath ->@@ -175,6 +175,49 @@ Then the test run fails and you will see that the stub function was not applied. ```haskell It has never been applied function `_ask`+```++## Partial mocking+The `makePartialMock` function can be used to mock only a part of a function defined in a typeclass.++For example, suppose you have the following typeclasses and functions. +`getUserInput` is the function to be tested.+```haskell+data UserInput = UserInput String deriving (Show, Eq)++class Monad m => UserInputGetter m where+ getInput :: m String+ toUserInput :: String -> m (Maybe UserInput)++getUserInput :: UserInputGetter m => m (Maybe UserInput)+getUserInput = do+ i <- getInput+ toUserInput i+```+In this example, we want to use real functions, so we define an `IO` instance as follows.+```haskell+instance UserInputGetter IO where+ getInput = getLine+ toUserInput "" = pure Nothing+ toUserInput a = (pure . Just . UserInput) a+```+The test will look like this.+```haskell+makePartialMock [t|UserInputGetter|]++spec :: Spec+spec = do+ it "Get user input (has input)" do+ a <- runMockT do+ _getInput "value"+ getUserInput+ a `shouldBe` Just (UserInput "value")++ it "Get user input (no input)" do+ a <- runMockT do+ _getInput ""+ getUserInput+ a `shouldBe` Nothing ``` ## Rename stub functions
mockcat.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: mockcat-version: 0.3.1.0+version: 0.4.0.0 synopsis: Mock library for test in Haskell. description: mockcat is a mock library for testing Haskell. .@@ -51,6 +51,7 @@ , mtl >=2.3.1 && <2.4 , template-haskell >=2.18 && <2.23 , text >=2.0 && <2.2+ , transformers >=0.5.6 && <0.7 default-language: Haskell2010 test-suite mockcat-test@@ -59,9 +60,13 @@ other-modules: Test.MockCat.AssociationListSpec Test.MockCat.ConsSpec+ Test.MockCat.Definition Test.MockCat.ExampleSpec+ Test.MockCat.Impl Test.MockCat.MockSpec Test.MockCat.ParamSpec+ Test.MockCat.PartialMockSpec+ Test.MockCat.PartialMockTHSpec Test.MockCat.TypeClassSpec Test.MockCat.TypeClassTHSpec Paths_mockcat@@ -75,4 +80,5 @@ , mtl >=2.3.1 && <2.4 , template-haskell >=2.18 && <2.23 , text >=2.0 && <2.2+ , transformers >=0.5.6 && <0.7 default-language: Haskell2010
src/Test/MockCat/MockT.hs view
@@ -6,6 +6,7 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} module Test.MockCat.MockT (MockT(..), Definition(..), runMockT, applyTimesIs, neverApply) where import Control.Monad.State+ ( StateT(..), MonadIO(..), MonadTrans(..), modify, execStateT ) import GHC.TypeLits (KnownSymbol) import Data.Data (Proxy) import Test.MockCat.Mock (Mock, shouldApplyTimesToAnything)
src/Test/MockCat/TH.hs view
@@ -1,51 +1,63 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unused-local-binds #-} -module Test.MockCat.TH (showExp, expectByExpr, makeMock, makeMockWithOptions, MockOptions(..), options) where+module Test.MockCat.TH+ ( showExp,+ expectByExpr,+ makeMock,+ makeMockWithOptions,+ MockOptions (..),+ options,+ makePartialMock,+ makePartialMockWithOptions,+ )+where +import Control.Monad (guard, unless)+import Control.Monad.State (get, modify)+import Control.Monad.Trans.Class (lift)+import Data.Data (Proxy (..))+import Data.Function ((&))+import Data.List (elemIndex, find, nub)+import Data.Maybe (fromMaybe, isJust)+import Data.Text (pack, splitOn, unpack)+import GHC.IO (unsafePerformIO)+import GHC.TypeLits (KnownSymbol, symbolVal) import Language.Haskell.TH- ( Exp(..),- Lit(..),- Pat(..),- Q,- pprint,- Name,- Dec(..),- Info(..),- reify,- mkName,- Type(..),- Quote(newName),- Cxt,- TyVarBndr(..),- Pred,- isExtEnabled,- Extension(..) )+ ( Cxt,+ Dec (..),+ Exp (..),+ Extension (..),+ Info (..),+ Lit (..),+ Name,+ Pat (..),+ Pred,+ Q,+ Quote (newName),+ TyVarBndr (..),+ Type (..),+ isExtEnabled,+ mkName,+ pprint,+ reify,+ )+import Language.Haskell.TH.Lib import Language.Haskell.TH.PprLib (Doc, hcat, parens, text) import Language.Haskell.TH.Syntax (nameBase)-import Test.MockCat.Param import Test.MockCat.Cons-import Test.MockCat.MockT import Test.MockCat.Mock-import Data.Data (Proxy(..))-import Data.List (find, nub, elemIndex)-import GHC.TypeLits (KnownSymbol, symbolVal)+import Test.MockCat.MockT+import Test.MockCat.Param import Unsafe.Coerce (unsafeCoerce)-import Control.Monad.State (modify, get)-import Data.Maybe (fromMaybe, isJust)-import GHC.IO (unsafePerformIO)-import Language.Haskell.TH.Lib-import Data.Text (splitOn, unpack, pack)-import Control.Monad (guard, unless)-import Data.Function ((&)) import Prelude as P showExp :: Q Exp -> Q String@@ -88,92 +100,137 @@ pprintLit (CharL c) = text (show c) pprintLit l = text (pprint l) -{- | Create a conditional parameter based on @Q Exp@. -- In applying a mock function, if the argument does not satisfy this condition, an error is raised.-- The conditional expression is displayed in the error message.--}+-- | Create a conditional parameter based on @Q Exp@.+--+-- In applying a mock function, if the argument does not satisfy this condition, an error is raised.+--+-- The conditional expression is displayed in the error message. expectByExpr :: Q Exp -> Q Exp expectByExpr qf = do str <- showExp qf [|ExpectCondition $qf str|] -{- | Options for generating mocks. -- - prefix: Stub function prefix- - suffix: stub function suffix--}-data MockOptions = MockOptions { prefix :: String, suffix :: String }+data MockType = Total | Partial deriving (Eq) -{- | Default Options.+-- | Options for generating mocks.+--+-- - prefix: Stub function prefix+-- - suffix: stub function suffix+data MockOptions = MockOptions {prefix :: String, suffix :: String} - Stub function names are prefixed with “_”.--}+-- | Default Options.+--+-- Stub function names are prefixed with “_”. options :: MockOptions-options = MockOptions { prefix = "_", suffix = "" }--{- | Create a mock of the typeclasses that returns a monad according to the `MockOptions`. -- Given a monad type class, generate the following.-- - MockT instance of the given typeclass- - A stub function corresponding to a function of the original class type.-The name of stub function is the name of the original function with a “_” appended.-- @- class (Monad m) => FileOperation m where- writeFile :: FilePath -\> Text -\> m ()- readFile :: FilePath -\> m Text-- makeMockWithOptions [t|FileOperation|] options { prefix = "stub_" }-- it "test runMockT" do- result \<- runMockT do- stub_readFile $ "input.txt" |\> pack "content"- stub_writeFile $ "output.text" |\> pack "content" |\> ()- somethingProgram-- result `shouldBe` ()- @+options = MockOptions {prefix = "_", suffix = ""} --}+-- | Create a mock of the typeclasses that returns a monad according to the `MockOptions`.+--+-- Given a monad type class, generate the following.+--+-- - MockT instance of the given typeclass+-- - A stub function corresponding to a function of the original class type.+-- The name of stub function is the name of the original function with a “_” appended.+--+-- @+-- class (Monad m) => FileOperation m where+-- writeFile :: FilePath -\> Text -\> m ()+-- readFile :: FilePath -\> m Text+--+-- makeMockWithOptions [t|FileOperation|] options { prefix = "stub_" }+--+-- it "test runMockT" do+-- result \<- runMockT do+-- stub_readFile $ "input.txt" |\> pack "content"+-- stub_writeFile $ "output.text" |\> pack "content" |\> ()+-- somethingProgram+--+-- result `shouldBe` ()+-- @ makeMockWithOptions :: Q Type -> MockOptions -> Q [Dec]-makeMockWithOptions = doMakeMock--{- | Create a mock of a typeclasses that returns a monad. -- Given a monad type class, generate the following.-- - MockT instance of the given typeclass- - A stub function corresponding to a function of the original class type.-The name of stub function is the name of the original function with a “_” appended.-- The prefix can be changed.- In that case, use `makeMockWithOptions`.-- @- class (Monad m) => FileOperation m where- writeFile :: FilePath -\> Text -\> m ()- readFile :: FilePath -\> m Text-- makeMock [t|FileOperation|]+makeMockWithOptions = flip doMakeMock Total - it "test runMockT" do- result \<- runMockT do- _readFile $ "input.txt" |\> pack "content"- _writeFile $ "output.text" |\> pack "content" |\> ()- somethingProgram+-- | Create a mock of a typeclasses that returns a monad.+--+-- Given a monad type class, generate the following.+--+-- - MockT instance of the given typeclass+-- - A stub function corresponding to a function of the original class type.+-- The name of stub function is the name of the original function with a “_” appended.+--+-- The prefix can be changed.+-- In that case, use `makeMockWithOptions`.+--+-- @+-- class (Monad m) => FileOperation m where+-- writeFile :: FilePath -\> Text -\> m ()+-- readFile :: FilePath -\> m Text+--+-- makeMock [t|FileOperation|]+--+-- spec :: Spec+-- spec = do+-- it "test runMockT" do+-- result \<- runMockT do+-- _readFile $ "input.txt" |\> pack "content"+-- _writeFile $ "output.text" |\> pack "content" |\> ()+-- somethingProgram+--+-- result `shouldBe` ()+-- @+makeMock :: Q Type -> Q [Dec]+makeMock t = doMakeMock t Total options - result `shouldBe` ()- @+-- | Create a partial mock of a typeclasses that returns a monad.+--+-- Given a monad type class, generate the following.+--+-- - MockT instance of the given typeclass+-- - A stub function corresponding to a function of the original class type.+-- The name of stub function is the name of the original function with a “_” appended.+--+-- For functions that are not stubbed in the test, the real function is used as appropriate for the context.+--+-- The prefix can be changed.+-- In that case, use `makePartialMockWithOptions`.+--+-- @+-- class Monad m => Finder a b m | a -> b, b -> a where+-- findIds :: m [a]+-- findById :: a -> m b+--+-- instance Finder Int String IO where+-- findIds = pure [1, 2, 3]+-- findById id = pure $ "{id: " <> show id <> "}"+--+-- findValue :: Finder a b m => m [b]+-- findValue = do+-- ids <- findIds+-- mapM findById ids+--+-- makePartialMock [t|Finder|]+--+-- spec :: Spec+-- spec = do+-- it "Use all real functions." do+-- values <- runMockT findValue+-- values `shouldBe` ["{id: 1}", "{id: 2}", "{id: 3}"]+--+-- it "Only findIds should be stubbed." do+-- values <- runMockT do+-- _findIds [1 :: Int, 2]+-- findValue+-- values `shouldBe` ["{id: 1}", "{id: 2}"]+-- @+makePartialMock :: Q Type -> Q [Dec]+makePartialMock t = doMakeMock t Partial options --}-makeMock :: Q Type -> Q [Dec]-makeMock = flip doMakeMock options+-- | `makePartialMock` with options+makePartialMockWithOptions :: Q Type -> MockOptions -> Q [Dec]+makePartialMockWithOptions = flip doMakeMock Partial -doMakeMock :: Q Type -> MockOptions -> Q [Dec]-doMakeMock t options = do+doMakeMock :: Q Type -> MockType -> MockOptions -> Q [Dec]+doMakeMock t mockType options = do verifyExtension DataKinds verifyExtension FlexibleInstances verifyExtension FlexibleContexts@@ -184,33 +241,26 @@ reify className >>= \case ClassI (ClassD _ _ [] _ _) _ -> fail $ "A type parameter is required for class " <> show className- ClassI (ClassD cxt _ typeVars _ decs) _ -> do monadVarNames <- getMonadVarNames cxt typeVars case nub monadVarNames of [] -> fail "Monad parameter not found." (monadVarName : rest) | length rest > 1 -> fail "Monad parameter must be unique."- | otherwise -> makeMockDecs ty className monadVarName cxt typeVars decs options-+ | otherwise -> makeMockDecs ty mockType className monadVarName cxt typeVars decs options t -> error $ "unsupported type: " <> show t --makeMockDecs :: Type -> Name -> Name -> Cxt -> [TyVarBndr a] -> [Dec] -> MockOptions -> Q [Dec]-makeMockDecs ty className monadVarName cxt typeVars decs options = do+makeMockDecs :: Type -> MockType -> Name -> Name -> Cxt -> [TyVarBndr a] -> [Dec] -> MockOptions -> Q [Dec]+makeMockDecs ty mockType className monadVarName cxt typeVars decs options = do let classParamNames = filter (className /=) (getClassNames ty) newTypeVars = drop (length classParamNames) typeVars- varAppliedTypes = zipWith (\t i -> VarAppliedType t (safeIndex classParamNames i)) (getTypeVarNames typeVars) [0..]-- newCxt <- createCxt monadVarName cxt- m <- appT (conT ''Monad) (varT monadVarName)-- let hasMonad = P.any (\(ClassName2VarNames c _) -> c == ''Monad) $ toClassInfos newCxt+ varAppliedTypes = zipWith (\t i -> VarAppliedType t (safeIndex classParamNames i)) (getTypeVarNames typeVars) [0 ..] - instanceDec <- instanceD- (pure $ newCxt ++ ([m | not hasMonad]))- (createInstanceType ty monadVarName newTypeVars)- (map (createInstanceFnDec options) decs)+ instanceDec <-+ instanceD+ (createCxt cxt mockType className monadVarName newTypeVars varAppliedTypes)+ (createInstanceType ty monadVarName newTypeVars)+ (map (createInstanceFnDec mockType options) decs) mockFnDecs <- concat <$> mapM (createMockFnDec monadVarName varAppliedTypes options) decs @@ -218,12 +268,11 @@ getMonadVarNames :: Cxt -> [TyVarBndr a] -> Q [Name] getMonadVarNames cxt typeVars = do- let- parentClassInfos = toClassInfos cxt+ let parentClassInfos = toClassInfos cxt - typeVarNames = getTypeVarNames typeVars- -- VarInfos (class names is empty)- emptyClassVarInfos = map (`VarName2ClassNames` []) typeVarNames+ typeVarNames = getTypeVarNames typeVars+ -- VarInfos (class names is empty)+ emptyClassVarInfos = map (`VarName2ClassNames` []) typeVarNames varInfos <- collectVarInfos parentClassInfos emptyClassVarInfos @@ -255,7 +304,7 @@ collectVarInfos classInfos = mapM (collectVarInfo classInfos) collectVarInfo :: [ClassName2VarNames] -> VarName2ClassNames -> Q VarName2ClassNames-collectVarInfo classInfos (VarName2ClassNames vName classNames) = do+collectVarInfo classInfos (VarName2ClassNames vName classNames) = do varClassNames <- collectVarClassNames vName classInfos pure $ VarName2ClassNames vName (classNames ++ varClassNames) @@ -270,13 +319,12 @@ Nothing -> pure [] Just i -> do ClassI (ClassD cxt _ typeVars _ _) _ <- reify cName- let- -- type variable names- typeVarNames = getTypeVarNames typeVars- -- type variable name of same position- typeVarName = typeVarNames !! i- -- parent class information- parentClassInfos = toClassInfos cxt+ let -- type variable names+ typeVarNames = getTypeVarNames typeVars+ -- type variable name of same position+ typeVarName = typeVarNames !! i+ -- parent class information+ parentClassInfos = toClassInfos cxt case parentClassInfos of [] -> pure [cName]@@ -287,8 +335,8 @@ filterClassInfo :: Name -> [ClassName2VarNames] -> [ClassName2VarNames] filterClassInfo name = filter (hasVarName name) where- hasVarName :: Name -> ClassName2VarNames -> Bool- hasVarName name (ClassName2VarNames _ varNames) = name `elem` varNames+ hasVarName :: Name -> ClassName2VarNames -> Bool+ hasVarName name (ClassName2VarNames _ varNames) = name `elem` varNames filterMonadicVarInfos :: [VarName2ClassNames] -> [VarName2ClassNames] filterMonadicVarInfos = filter hasMonadInVarInfo@@ -296,9 +344,27 @@ hasMonadInVarInfo :: VarName2ClassNames -> Bool hasMonadInVarInfo (VarName2ClassNames _ classNames) = ''Monad `elem` classNames -createCxt :: Name -> Cxt -> Q Cxt-createCxt monadVarName = mapM (createPred monadVarName)+createCxt :: [Pred] -> MockType -> Name -> Name -> [TyVarBndr a] -> [VarAppliedType] -> Q [Pred]+createCxt cxt mockType className monadVarName tyVars varAppliedTypes = do+ newCxt <- mapM (createPred monadVarName) cxt + monadAppT <- appT (conT ''Monad) (varT monadVarName)++ let hasMonad = P.any (\(ClassName2VarNames c _) -> c == ''Monad) $ toClassInfos newCxt++ pure $ case mockType of+ Total -> newCxt ++ ([monadAppT | not hasMonad])+ Partial -> do+ let classAppT = constructClassAppT className $ toVarTs tyVars+ varAppliedClassAppT = updateType classAppT varAppliedTypes+ newCxt ++ ([monadAppT | not hasMonad]) ++ [varAppliedClassAppT]++toVarTs :: [TyVarBndr a] -> [Type]+toVarTs tyVars = VarT <$> getTypeVarNames tyVars++constructClassAppT :: Name -> [Type] -> Type+constructClassAppT className = foldl AppT (ConT className)+ createPred :: Name -> Pred -> Q Pred createPred monadVarName a@(AppT t@(ConT ty) b@(VarT varName)) | monadVarName == varName && ty == ''Monad = pure a@@ -323,57 +389,83 @@ | monadName == name = appT (conT ''MockT) (varT monadName) | otherwise = varT name -createInstanceFnDec :: MockOptions -> Dec -> Q Dec-createInstanceFnDec options (SigD fnName funType) = do+createInstanceFnDec :: MockType -> MockOptions -> Dec -> Q Dec+createInstanceFnDec mockType options (SigD fnName funType) = do names <- sequence $ typeToNames funType let r = mkName "result" params = varP <$> names args = varE <$> names fnNameStr = createFnName fnName options- genStubFn = case names of- [] -> $([|generateConstantStubFn|])- _ -> $([|generateStubFn args|]) - fnBody = [| MockT $ do- defs <- get- let mock = defs- & findParam (Proxy :: Proxy $(litT (strTyLit fnNameStr)))- & fromMaybe (error $ "no answer found stub function `" ++ fnNameStr ++ "`.")- $(bangP $ varP r) = $(genStubFn [| mock |])- pure $(varE r) |]+ fnBody = case mockType of+ Total -> generateInstanceMockFnBody fnNameStr args r+ Partial -> generateInstanceRealFnBody fnName fnNameStr args r+ fnClause = clause params (normalB fnBody) [] funD fnName [fnClause]-createInstanceFnDec _ dec = fail $ "unsuported dec: " <> pprint dec+createInstanceFnDec _ _ dec = fail $ "unsuported dec: " <> pprint dec +generateInstanceMockFnBody :: String -> [Q Exp] -> Name -> Q Exp+generateInstanceMockFnBody fnNameStr args r =+ [|+ MockT $ do+ defs <- get+ let mock =+ defs+ & findParam (Proxy :: Proxy $(litT (strTyLit fnNameStr)))+ & fromMaybe (error $ "no answer found stub function `" ++ fnNameStr ++ "`.")+ $(bangP $ varP r) = $(generateStubFn args [|mock|])+ pure $(varE r)+ |]++generateInstanceRealFnBody :: Name -> String -> [Q Exp] -> Name -> Q Exp+generateInstanceRealFnBody fnName fnNameStr args r =+ [|+ MockT $ do+ defs <- get+ case findParam (Proxy :: Proxy $(litT (strTyLit fnNameStr))) defs of+ Just mock -> do+ let $(bangP $ varP r) = $(generateStubFn args [|mock|])+ pure $(varE r)+ Nothing -> lift $ $(foldl appE (varE fnName) args)+ |]+ generateStubFn :: [Q Exp] -> Q Exp -> Q Exp-generateStubFn args mock = foldl appE [| stubFn $(mock) |] args+generateStubFn [] = $([|generateConstantStubFn|])+generateStubFn args = $([|generateNotConstantsStubFn args|]) +generateNotConstantsStubFn :: [Q Exp] -> Q Exp -> Q Exp+generateNotConstantsStubFn args mock = foldl appE [|stubFn $(mock)|] args+ generateConstantStubFn :: Q Exp -> Q Exp-generateConstantStubFn mock = [| stubFn $(mock) |]+generateConstantStubFn mock = [|stubFn $(mock)|] createMockFnDec :: Name -> [VarAppliedType] -> MockOptions -> Dec -> Q [Dec] createMockFnDec monadVarName varAppliedTypes options (SigD funName ty) = do let funNameStr = createFnName funName options mockFunName = mkName funNameStr params = mkName "p"-- if isConstant ty then- doCreateConstantMockFnDec funNameStr mockFunName params monadVarName- else do- let updatedType = updateType ty varAppliedTypes funType = createMockBuilderFnType monadVarName updatedType++ if isFunctionType ty then doCreateMockFnDec funNameStr mockFunName params funType monadVarName updatedType+ else+ doCreateConstantMockFnDec funNameStr mockFunName funType monadVarName createMockFnDec _ _ _ dec = fail $ "unsupport dec: " <> pprint dec -doCreateMockFnDec :: Quote m => String -> Name -> Name -> Type -> Name -> Type -> m [Dec]+doCreateMockFnDec :: (Quote m) => String -> Name -> Name -> Type -> Name -> Type -> m [Dec] doCreateMockFnDec funNameStr mockFunName params funType monadVarName updatedType = do newFunSig <- do let verifyParams = createMockBuilderVerifyParams updatedType- sigD mockFunName [t|- (MockBuilder $(varT params) ($(pure funType)) ($(pure verifyParams)), Monad $(varT monadVarName))- => $(varT params) -> MockT $(varT monadVarName) ()|]+ sigD+ mockFunName+ [t|+ (MockBuilder $(varT params) ($(pure funType)) ($(pure verifyParams)), Monad $(varT monadVarName)) =>+ $(varT params) ->+ MockT $(varT monadVarName) ()+ |] createMockFn <- [|createNamedMock|] @@ -382,32 +474,39 @@ pure $ newFunSig : [newFun] -doCreateConstantMockFnDec :: Quote m => String -> Name -> Name -> Name -> m [Dec]-doCreateConstantMockFnDec funNameStr mockFunName params monadVarName = do- newFunSig <- sigD mockFunName [t|Monad $(varT monadVarName) => $(varT params) -> MockT $(varT monadVarName) ()|]+doCreateConstantMockFnDec :: (Quote m) => String -> Name -> Type -> Name -> m [Dec]+doCreateConstantMockFnDec funNameStr mockFunName ty monadVarName = do+ newFunSig <- sigD mockFunName [t|(Monad $(varT monadVarName)) => $(pure ty) -> MockT $(varT monadVarName) ()|] createMockFn <- [|createNamedConstantMock|] mockBody <- createMockBody funNameStr createMockFn newFun <- funD mockFunName [clause [varP $ mkName "p"] (normalB (pure mockBody)) []] pure $ newFunSig : [newFun] -createMockBody :: Quote m => String -> Exp -> m Exp+createMockBody :: (Quote m) => String -> Exp -> m Exp createMockBody funNameStr createMockFn =- [| MockT $ modify (++ [Definition- (Proxy :: Proxy $(litT (strTyLit funNameStr)))- (unsafePerformIO $ $(pure createMockFn) $(litE (stringL funNameStr)) p)- shouldApplyToAnything]) |]+ [|+ MockT $+ modify+ ( +++ [ Definition+ (Proxy :: Proxy $(litT (strTyLit funNameStr)))+ (unsafePerformIO $ $(pure createMockFn) $(litE (stringL funNameStr)) p)+ shouldApplyToAnything+ ]+ )+ |] -isConstant :: Type -> Bool-isConstant (AppT (VarT _) (VarT _)) = True-isConstant (VarT _) = True-isConstant (ConT _) = True-isConstant _ = False+isFunctionType :: Type -> Bool+isFunctionType (AppT (AppT ArrowT _) _) = True+isFunctionType (AppT t1 t2) = isFunctionType t1 || isFunctionType t2+isFunctionType (TupleT _) = False+isFunctionType (ForallT _ _ t) = isFunctionType t+isFunctionType _ = False updateType :: Type -> [VarAppliedType] -> Type updateType (AppT (VarT v1) (VarT v2)) varAppliedTypes = do- let- x = maybe (VarT v1) ConT (findClass v1 varAppliedTypes)- y = maybe (VarT v2) ConT (findClass v2 varAppliedTypes)+ let x = maybe (VarT v1) ConT (findClass v1 varAppliedTypes)+ y = maybe (VarT v2) ConT (findClass v2 varAppliedTypes) AppT x y updateType ty _ = ty @@ -435,12 +534,12 @@ createMockBuilderVerifyParams :: Type -> Type createMockBuilderVerifyParams (AppT (AppT ArrowT ty) (AppT (VarT _) _)) = AppT (ConT ''Param) ty createMockBuilderVerifyParams (AppT (AppT ArrowT ty) ty2) =- AppT (AppT (ConT ''(:>)) (AppT (ConT ''Param) ty) ) (createMockBuilderVerifyParams ty2)+ AppT (AppT (ConT ''(:>)) (AppT (ConT ''Param) ty)) (createMockBuilderVerifyParams ty2) createMockBuilderVerifyParams (AppT (VarT _) (ConT c)) = AppT (ConT ''Param) (ConT c) createMockBuilderVerifyParams (ForallT _ _ ty) = createMockBuilderVerifyParams ty createMockBuilderVerifyParams a = a -findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe a+findParam :: (KnownSymbol sym) => Proxy sym -> [Definition] -> Maybe a findParam pa definitions = do let definition = find (\(Definition s _ _) -> symbolVal s == symbolVal pa) definitions fmap (\(Definition _ mock _) -> unsafeCoerce mock) definition@@ -471,7 +570,7 @@ instance Show VarName2ClassNames where show (VarName2ClassNames varName classNames) = show varName <> " class is " <> unwords (showClassName <$> classNames) -data VarAppliedType = VarAppliedType { name :: Name, appliedClassName :: Maybe Name }+data VarAppliedType = VarAppliedType {name :: Name, appliedClassName :: Maybe Name} deriving (Show) showClassName :: Name -> String@@ -488,9 +587,9 @@ safeIndex :: [a] -> Int -> Maybe a safeIndex [] _ = Nothing-safeIndex (x:_) 0 = Just x-safeIndex (_:xs) n- | n < 0 = Nothing+safeIndex (x : _) 0 = Just x+safeIndex (_ : xs) n+ | n < 0 = Nothing | otherwise = safeIndex xs (n - 1) verifyExtension :: Extension -> Q ()
test/Spec.hs view
@@ -6,6 +6,8 @@ import Test.MockCat.ExampleSpec as Example import Test.MockCat.TypeClassSpec as TypeClass import Test.MockCat.TypeClassTHSpec as TypeClassTH+import Test.MockCat.PartialMockSpec as PartialMock+import Test.MockCat.PartialMockTHSpec as PartialMockTH main :: IO () main = do@@ -17,3 +19,5 @@ Example.spec TypeClass.spec TypeClassTH.spec+ PartialMock.spec+ PartialMockTH.spec
+ test/Test/MockCat/Definition.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FunctionalDependencies #-}+module Test.MockCat.Definition (FileOperation(..), Finder(..), program, findValue) where++import Data.Text+import Prelude hiding (readFile, writeFile)++class Monad m => FileOperation m where+ readFile :: FilePath -> m Text+ writeFile :: FilePath -> Text -> m ()++program ::+ FileOperation m =>+ FilePath ->+ FilePath ->+ m ()+program inputPath outputPath = do+ content <- readFile inputPath+ writeFile outputPath content++class Monad m => Finder a b m | a -> b, b -> a where+ findIds :: m [a]+ findById :: a -> m b++findValue :: Finder a b m => m [b]+findValue = do+ ids <- findIds+ mapM findById ids
+ test/Test/MockCat/Impl.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+module Test.MockCat.Impl (FileOperation, Finder) where++import Test.MockCat.Definition+import Data.Text+import Prelude hiding (readFile, writeFile)+import Control.Monad.Trans.Maybe+import Control.Monad.Reader++instance FileOperation IO where+ readFile _ = pure $ pack "IO content"+ writeFile _ _ = pure ()++instance Monad m => FileOperation (MaybeT m) where+ readFile _ = pure $ pack "MaybeT content"+ writeFile _ _ = undefined++instance Monad m => FileOperation (ReaderT String m) where+ readFile _ = do+ e <- ask+ pure $ pack "ReaderT content " <> pack e+ writeFile _ _ = undefined++instance Finder Int String IO where+ findIds = pure [1, 2, 3]+ findById id = pure $ "{id: " <> show id <> "}"
+ test/Test/MockCat/PartialMockSpec.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Test.MockCat.PartialMockSpec (spec) where++import Data.Text (Text, pack)+import Test.Hspec (Spec, it, shouldBe, describe)+import Test.MockCat+import Test.MockCat.Definition+import Test.MockCat.Impl ()+import Prelude hiding (readFile, writeFile)+import Data.Data+import Data.List (find)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Unsafe.Coerce (unsafeCoerce)+import GHC.IO (unsafePerformIO)+import Control.Monad.State+import Control.Monad.Trans.Maybe (MaybeT (..))+import Control.Monad.Trans.Reader hiding (ask)++instance (Monad m, FileOperation m) => FileOperation (MockT m) where+ readFile path = MockT do+ defs <- get+ case findParam (Proxy :: Proxy "readFile") defs of+ Just mock -> do+ let !result = stubFn mock path+ pure result+ Nothing -> lift $ readFile path++ writeFile path content = MockT do+ defs <- get+ case findParam (Proxy :: Proxy "writeFile") defs of+ Just mock -> do+ let !result = stubFn mock path content+ pure result+ Nothing -> lift $ writeFile path content++_readFile :: (MockBuilder params (FilePath -> Text) (Param FilePath), Monad m) => params -> MockT m ()+_readFile p = MockT $ do+ modify (++ [Definition+ (Proxy :: Proxy "readFile")+ (unsafePerformIO $ createNamedMock "readFile" p)+ shouldApplyToAnything])++_writeFile :: (MockBuilder params (FilePath -> Text -> ()) (Param FilePath :> Param Text), Monad m) => params -> MockT m ()+_writeFile p = MockT $ modify (++ [Definition+ (Proxy :: Proxy "writeFile")+ (unsafePerformIO $ createNamedMock "writeFile" p)+ shouldApplyToAnything])++findParam :: KnownSymbol sym => Proxy sym -> [Definition] -> Maybe a+findParam pa definitions = do+ let definition = find (\(Definition s _ _) -> symbolVal s == symbolVal pa) definitions+ fmap (\(Definition _ mock _) -> unsafeCoerce mock) definition++instance (Monad m, Finder a b m) => Finder a b (MockT m) where+ findIds :: (Monad m, Finder a b m) => MockT m [a]+ findIds = MockT do+ defs <- get+ case findParam (Proxy :: Proxy "_findIds") defs of+ Just mock -> do+ let !result = stubFn mock+ pure result+ Nothing -> lift findIds+ findById :: (Monad m, Finder a b m) => a -> MockT m b+ findById id = MockT do+ defs <- get+ case findParam (Proxy :: Proxy "_findById") defs of+ Just mock -> do+ let !result = stubFn mock id+ pure result+ Nothing -> lift $ findById id++_findIds :: Monad m => r -> MockT m ()+_findIds p = MockT do+ modify (++ [Definition+ (Proxy :: Proxy "_findIds")+ (unsafePerformIO $ createNamedConstantMock "_findIds" p) shouldApplyToAnything])++spec :: Spec+spec = do+ describe "Partial Mock Test" do+ it "MaybeT" do+ result <- runMaybeT do+ runMockT do+ _writeFile $ "output.text" |> pack "MaybeT content" |> ()+ program "input.txt" "output.text"++ result `shouldBe` Just ()++ it "IO" do+ result <- runMockT do+ _writeFile $ "output.text" |> pack "IO content" |> ()+ program "input.txt" "output.text"++ result `shouldBe` ()++ it "ReaderT" do+ result <- flip runReaderT "foo" do+ runMockT do+ _writeFile $ "output.text" |> pack "ReaderT content foo" |> ()+ program "input.txt" "output.text"++ result `shouldBe` ()+ + describe "MultiParamType" do+ it "all real function" do+ values <- runMockT findValue+ values `shouldBe` ["{id: 1}", "{id: 2}", "{id: 3}"]++ it "partial 1" do+ values <- runMockT do+ _findIds [1 :: Int, 2]+ findValue+ values `shouldBe` ["{id: 1}", "{id: 2}"]
+ test/Test/MockCat/PartialMockTHSpec.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++module Test.MockCat.PartialMockTHSpec (spec) where++import Data.Text (pack)+import Test.Hspec (Spec, it, shouldBe, describe)+import Test.MockCat+import Test.MockCat.Definition+import Test.MockCat.Impl ()+import Prelude hiding (readFile, writeFile)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Control.Monad.Reader (ReaderT(..))++data UserInput = UserInput String deriving (Show, Eq)++class Monad m => UserInputGetter m where+ getInput :: m String+ toUserInput :: String -> m (Maybe UserInput)++getUserInput :: UserInputGetter m => m (Maybe UserInput)+getUserInput = do+ i <- getInput+ toUserInput i++instance UserInputGetter IO where+ getInput = getLine+ toUserInput "" = pure Nothing+ toUserInput a = (pure . Just . UserInput) a++makePartialMock [t|UserInputGetter|]+makePartialMock [t|Finder|]+makePartialMock [t|FileOperation|]++spec :: Spec+spec = do+ it "Get user input (has input)" do+ a <- runMockT do+ _getInput "value"+ getUserInput+ a `shouldBe` Just (UserInput "value")++ it "Get user input (no input)" do+ a <- runMockT do+ _getInput ""+ getUserInput+ a `shouldBe` Nothing++ describe "Partial Mock Test (TH)" do+ it "MaybeT" do+ result <- runMaybeT do+ runMockT do+ _writeFile $ "output.text" |> pack "MaybeT content" |> ()+ program "input.txt" "output.text"++ result `shouldBe` Just ()++ it "IO" do+ result <- runMockT do+ _writeFile $ "output.text" |> pack "IO content" |> ()+ program "input.txt" "output.text"++ result `shouldBe` ()++ it "ReaderT" do+ result <- flip runReaderT "foo" do+ runMockT do+ _writeFile $ "output.text" |> pack "ReaderT content foo" |> ()+ program "input.txt" "output.text"++ result `shouldBe` ()++ describe "MultiParamType" do+ it "all real function" do+ values <- runMockT findValue+ values `shouldBe` ["{id: 1}", "{id: 2}", "{id: 3}"]++ it "partial findIds" do+ values <- runMockT do+ _findIds [1 :: Int, 2]+ findValue+ values `shouldBe` ["{id: 1}", "{id: 2}"]++ it "partial findById" do+ values <- runMockT do+ _findById [+ (1 :: Int) |> "id1",+ (2 :: Int) |> "id2",+ (3 :: Int) |> "id3"+ ]+ findValue+ values `shouldBe` ["id1", "id2", "id3"]