monad-mock 0.1.0.0 → 0.1.1.0
raw patch · 8 files changed
+607/−73 lines, 8 filesdep +haskell-src-extsdep +haskell-src-metadep +template-haskell
Dependencies added: haskell-src-exts, haskell-src-meta, template-haskell, th-orphans
Files
- CHANGELOG.md +7/−0
- README.md +5/−4
- library/Control/Monad/Mock.hs +49/−46
- library/Control/Monad/Mock/TH.hs +407/−0
- library/Control/Monad/Mock/TH/Internal/TypesQuasi.hs +114/−0
- monad-mock.cabal +11/−3
- package.yaml +8/−1
- test-suite/Control/Monad/MockSpec.hs +6/−19
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+## 0.1.1.0 (June 27th, 2017)++- Added `Control.Monad.Mock.TH`, which provides functions for automatically generating actions using Template Haskell.++## 0.1.0.0 (June 23rd, 2017)++- Initial release
README.md view
@@ -15,17 +15,18 @@ in a completely pure way: ```haskell-copyFile :: MonadFileSystem m => FilePath -> FilePath -> m String+copyFile :: MonadFileSystem m => FilePath -> FilePath -> m () copyFile a b = do x <- readFile a writeFile b x- return x +makeMock "FileSystemAction" [ts| MonadFileSystem |]+ spec = describe "copyFile" $ it "reads a file and writes its contents to another file" $ evaluate $ copyFile "foo.txt" "bar.txt"- & runMockT [ ReadFile "foo.txt" :-> "contents"- , WriteFile "bar.txt" "contents" :-> () ]+ & runMock [ ReadFile "foo.txt" :-> "contents"+ , WriteFile "bar.txt" "contents" :-> () ] ``` For more information, [see the documentation on Hackage][monad-mock].
library/Control/Monad/Mock.hs view
@@ -1,62 +1,65 @@ {-# LANGUAGE UndecidableInstances #-} {-|- This module provides a monad transformer that helps create “mocks” of- @mtl@-style typeclasses, intended for use in unit tests. A mock can be- executed by providing a sequence of expected monadic calls and their results,- and the mock will verify that the computation conforms to the expectation.+This module provides a monad transformer that helps create “mocks” of+@mtl@-style typeclasses, intended for use in unit tests. A mock can be+executed by providing a sequence of expected monadic calls and their results,+and the mock will verify that the computation conforms to the expectation. - For example, imagine a @MonadFileSystem@ typeclass, which describes a class of- monads that may perform filesystem operations:+For example, imagine a @MonadFileSystem@ typeclass, which describes a class of+monads that may perform filesystem operations: - @- class 'Monad' m => MonadFileSystem m where- readFile :: 'FilePath' -> m 'String'- writeFile :: 'FilePath' -> 'String' -> m ()- @+@+class 'Monad' m => MonadFileSystem m where+ readFile :: 'FilePath' -> m 'String'+ writeFile :: 'FilePath' -> 'String' -> m ()+@ - Using 'MockT', it’s possible to test computations that use @MonadFileSystem@- in a completely pure way:+Using 'MockT', it’s possible to test computations that use @MonadFileSystem@+in a completely pure way: - @- copyFile :: MonadFileSystem m => 'FilePath' -> 'FilePath' -> m 'String'- copyFile a b = do- x <- readFile a- writeFile b x- 'return' x+@+copyFile :: MonadFileSystem m => 'FilePath' -> 'FilePath' -> m ()+copyFile a b = do+ x <- readFile a+ writeFile b x - spec = describe "copyFile" '$'- it "reads a file and writes its contents to another file" '$'- 'Control.Exception.evaluate' '$' copyFile "foo.txt" "bar.txt"- 'Data.Function.&' 'runMockT' [ ReadFile "foo.txt" ':->' "contents"- , WriteFile "bar.txt" "contents" ':->' () ]- @+spec = describe "copyFile" '$'+ it "reads a file and writes its contents to another file" '$'+ 'Control.Exception.evaluate' '$' copyFile "foo.txt" "bar.txt"+ 'Data.Function.&' 'runMock' [ ReadFile "foo.txt" ':->' "contents"+ , WriteFile "bar.txt" "contents" ':->' () ]+@ - To make the above code work, all you have to do is write a small GADT that- represents typeclass method calls and implement the 'Action' typeclass:+To make the above code work, all you have to do is write a small GADT that+represents typeclass method calls and implement the 'Action' typeclass: - @- data FileSystemAction r where- ReadFile :: 'FilePath' -> FileSystemAction 'String'- WriteFile :: 'FilePath' -> 'String' -> FileSystemAction ()- deriving instance 'Eq' (FileSystemAction r)- deriving instance 'Show' (FileSystemAction r)+@+data FileSystemAction r where+ ReadFile :: 'FilePath' -> FileSystemAction 'String'+ WriteFile :: 'FilePath' -> 'String' -> FileSystemAction ()+deriving instance 'Eq' (FileSystemAction r)+deriving instance 'Show' (FileSystemAction r) - instance 'Action' FileSystemAction where- 'eqAction' (ReadFile a) (ReadFile b)- = if a '==' b then 'Just' 'Refl' else 'Nothing'- 'eqAction' (WriteFile a b) (WriteFile c d)- = if a '==' c && b '==' d then 'Just' 'Refl' else 'Nothing'- 'eqAction' _ _ = 'Nothing'- @+instance 'Action' FileSystemAction where+ 'eqAction' (ReadFile a) (ReadFile b)+ = if a '==' b then 'Just' 'Refl' else 'Nothing'+ 'eqAction' (WriteFile a b) (WriteFile c d)+ = if a '==' c && b '==' d then 'Just' 'Refl' else 'Nothing'+ 'eqAction' _ _ = 'Nothing'+@ - Then, just write a @MonadFileSystem@ instance for 'MockT':+Then, just write a @MonadFileSystem@ instance for 'MockT': - @- instance 'Monad' m => MonadFileSystem ('MockT' FileSystemAction m) where- readFile a = 'mockAction' "readFile" (ReadFile a)- writeFile a b = 'mockAction' "writeFile" (WriteFile a b)- @+@+instance 'Monad' m => MonadFileSystem ('MockT' FileSystemAction m) where+ readFile a = 'mockAction' "readFile" (ReadFile a)+ writeFile a b = 'mockAction' "writeFile" (WriteFile a b)+@++For some Template Haskell functions that eliminate the need to write the above+boilerplate, look at 'Control.Monad.Mock.TH.makeAction' from+"Control.Monad.Mock.TH". -} module Control.Monad.Mock ( -- * The MockT monad transformer
+ library/Control/Monad/Mock/TH.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++{-|+This module provides Template Haskell functions for automatically generating+types representing typeclass methods for use with "Control.Monad.Mock". The+resulting datatypes can be used with 'Control.Monad.Mock.runMock' or+'Control.Monad.Mock.runMockT' to mock out functionality in unit tests.++The primary interface to this module is the 'makeAction' function, which+generates an action GADT given a list of mtl-style typeclass constraints. For+example, consider a typeclass that encodes side-effectful monadic operations:++@+class 'Monad' m => MonadFileSystem m where+ readFile :: 'FilePath' -> m 'String'+ writeFile :: 'FilePath' -> 'String' -> m ()+@++The typeclass has an obvious, straightforward instance for 'IO'. However, one+of the main value of using a typeclass is that a alternate, pure instance may+be provided for unit tests, which is what 'MockT' provides. Therefore, one+might use 'makeAction' to automatically generate the necessary datatype and+instances:++@+'makeAction' "FileSystemAction" ['ts'| MonadFileSystem |]+@++This generates three things:++ 1. A @FileSystemAction@ GADT with constructors that correspond to the+ methods of @MonadFileSystem@.++ 2. An 'Action' instance for @FileSystemAction@.++ 3. A 'MonadFileSystem' instance for @'MockT' FileSystemAction m@.++The generated code effectively looks like this:++@+data FileSystemAction r where+ ReadFile :: 'FilePath' -> FileSystemAction 'String'+ WriteFile :: 'FilePath' -> 'String' -> FileSystemAction ()+deriving instance 'Eq' (FileSystemAction r)+deriving instance 'Show' (FileSystemAction r)++instance 'Action' FileSystemAction where+ 'eqAction' (ReadFile a) (ReadFile b)+ = if a '==' b then 'Just' 'Refl' else 'Nothing'+ 'eqAction' (WriteFile a b) (WriteFile c d)+ = if a '==' c && b '==' d then 'Just' 'Refl' else 'Nothing'+ 'eqAction' _ _ = 'Nothing'++instance 'Monad' m => MonadFileSystem ('MockT' FileSystemAction m) where+ readFile a = 'mockAction' "readFile" (ReadFile a)+ writeFile a b = 'mockAction' "writeFile" (WriteFile a b)+@++This can then be used in tandem with 'Control.Monad.Mock.runMock' to unit-test+a function that interacts with the file system in a completely pure way:++@+copyFile :: MonadFileSystem m => 'FilePath' -> 'FilePath' -> m ()+copyFile a b = do+ x <- readFile a+ writeFile b x++spec = describe "copyFile" '$'+ it "reads a file and writes its contents to another file" '$'+ 'Control.Exception.evaluate' '$' copyFile "foo.txt" "bar.txt"+ 'Data.Function.&' 'runMock' [ ReadFile "foo.txt" ':->' "contents"+ , WriteFile "bar.txt" "contents" ':->' () ]+@+-}+module Control.Monad.Mock.TH (makeAction, deriveAction, ts) where++import Control.Monad (replicateM, when, zipWithM)+import Data.Char (toUpper)+import Data.Foldable (traverse_)+import Data.List (foldl', nub, partition)+import Data.Type.Equality ((:~:)(..))+import GHC.Exts (Constraint)+import Language.Haskell.TH++import Control.Monad.Mock (Action(..), MockT, mockAction)+import Control.Monad.Mock.TH.Internal.TypesQuasi (ts)++-- | Given a list of monadic typeclass constraints of kind @* -> 'Constraint'@,+-- generate a type with an 'Action' instance with constructors that have the+-- same types as the methods.+--+-- @+-- class 'Monad' m => MonadFileSystem m where+-- readFile :: 'FilePath' -> m 'String'+-- writeFile :: 'FilePath' -> 'String' -> m ()+--+-- 'makeAction' "FileSystemAction" ['ts'| MonadFileSystem |]+-- @+makeAction :: String -> Cxt -> Q [Dec]+makeAction actionNameStr classTs = do+ traverse_ assertDerivableConstraint classTs++ actionParamName <- newName "r"+ let actionName = mkName actionNameStr+ actionTypeCon = ConT actionName++ classInfos <- traverse reify (map unappliedTypeName classTs)+ methods <- traverse classMethods classInfos+ actionCons <- concat <$> zipWithM (methodsToConstructors actionTypeCon) classTs methods++ let actionDec = DataD [] actionName [PlainTV actionParamName] Nothing actionCons []+ mkStandaloneDec derivT = StandaloneDerivD [] (derivT `AppT` (actionTypeCon `AppT` VarT actionParamName))+ standaloneDecs = [mkStandaloneDec (ConT ''Eq), mkStandaloneDec (ConT ''Show)]+ actionInstanceDec <- deriveAction' actionTypeCon actionCons+ classInstanceDecs <- zipWithM (mkInstance actionTypeCon) classTs methods++ return $ [actionDec] ++ standaloneDecs ++ [actionInstanceDec] ++ classInstanceDecs+ where+ -- | Ensures that a provided constraint is something monad-mock can actually+ -- derive an instance for. Specifically, it must be a constraint of kind+ -- @* -> 'Constraint'@, and anything else is invalid.+ assertDerivableConstraint :: Type -> Q ()+ assertDerivableConstraint classType = do+ info <- reify $ unappliedTypeName classType+ (ClassD _ _ classVars _ _) <- case info of+ ClassI dec _ -> return dec+ _ -> fail $ "makeAction: expected a constraint, given ‘" ++ show (ppr classType) ++ "’"++ let classArgs = typeArgs classType+ let mkClassKind vars = foldr (\a b -> AppT (AppT ArrowT a) b) (ConT ''Constraint) (reverse varKinds)+ where varKinds = map (\(KindedTV _ k) -> k) vars+ constraintStr = show (ppr (ConT ''Constraint))++ when (length classArgs > length classVars) $+ fail $ "makeAction: too many arguments for class\n"+ ++ " in: " ++ show (ppr classType) ++ "\n"+ ++ " for class of kind: " ++ show (ppr (mkClassKind classVars))++ when (length classArgs == length classVars) $+ fail $ "makeAction: cannot derive instance for fully saturated constraint\n"+ ++ " in: " ++ show (ppr classType) ++ "\n"+ ++ " expected: * -> " ++ constraintStr ++ "\n"+ ++ " given: " ++ constraintStr++ when (length classArgs < length classVars - 1) $+ fail $ "makeAction: cannot derive instance for multi-parameter typeclass\n"+ ++ " in: " ++ show (ppr classType) ++ "\n"+ ++ " expected: * -> " ++ constraintStr ++ "\n"+ ++ " given: " ++ show (ppr (mkClassKind $ drop (length classArgs) classVars))++ -- | Converts a class’s methods to constructors for an action type. There+ -- are two operations involved in this conversion:+ --+ -- 1. Capitalize the first character of the method name to make it a valid+ -- data constructor name.+ --+ -- 2. Replace the type variable bound by the typeclass constraint. To+ -- explain this step, consider the following typeclass:+ --+ -- > class Monad m => MonadFoo m where+ -- > foo :: String -> m Foo+ --+ -- The signature for @foo@ is really as follows:+ --+ -- > forall m. MonadFoo m => String -> m Foo+ --+ -- However, when converted to a GADT, we want it to look like this:+ --+ -- > data SomeAction f where+ -- > Foo :: String -> SomeAction Foo+ --+ -- Specifically, we want to remove the @m@ quantified type variable,+ -- and we want to replace it with the @SomeAction@ type constructor+ -- itself.+ --+ -- To accomplish this, 'methodToConstructors' accepts two 'Type's,+ -- where the first is the action type constructor, and the second is+ -- the constraint which must be removed.+ methodsToConstructors :: Type -> Type -> [Dec] -> Q [Con]+ methodsToConstructors actionT classT = traverse (methodToConstructor actionT classT)++ -- | Converts a single class method into a constructor for an action type.+ methodToConstructor :: Type -> Type -> Dec -> Q Con+ methodToConstructor actionT classT (SigD name typ) = do+ let constructorName = methodNameToConstructorName name+ newT <- replaceClassConstraint classT actionT typ+ let (tyVars, ctx, argTs, resultT) = splitFnType newT+ noStrictness = Bang NoSourceUnpackedness NoSourceStrictness+ gadtCon = GadtC [constructorName] (map (noStrictness,) argTs) resultT+ return $ ForallC tyVars ctx gadtCon+ methodToConstructor _ _ _ = fail "methodToConstructor: internal error; report a bug with the monad-mock package"++ -- | Converts an ordinary term-level identifier, which starts with a+ -- lower-case letter, to a data constructor, which starts with an upper-+ -- case letter.+ methodNameToConstructorName :: Name -> Name+ methodNameToConstructorName name = mkName (toUpper c : cs)+ where (c:cs) = nameBase name++ mkInstance :: Type -> Type -> [Dec] -> Q Dec+ mkInstance actionT classT methodSigs = do+ mVar <- newName "m"+ methodImpls <- traverse mkInstanceMethod methodSigs+ let instanceHead = classT `AppT` (ConT ''MockT `AppT` actionT `AppT` VarT mVar)+ return $ InstanceD Nothing [ConT ''Monad `AppT` VarT mVar] instanceHead methodImpls++ mkInstanceMethod :: Dec -> Q Dec+ mkInstanceMethod (SigD name typ) = do+ let constructorName = methodNameToConstructorName name+ arity = fnTypeArity typ++ argNames <- replicateM arity (newName "x")+ let pats = map VarP argNames+ conCall = foldl' AppE (ConE constructorName) (map VarE argNames)+ mockCall = VarE 'mockAction `AppE` LitE (StringL $ nameBase name) `AppE` conCall++ return $ FunD name [Clause pats (NormalB mockCall) []]+ mkInstanceMethod _ = fail "mkInstanceMethod: internal error; report a bug with the monad-mock package"++-- | Implements the class constraint replacement functionality as described in+-- the documentation for 'methodsToConstructors'. Given a type that represents+-- the typeclass whose constraint must be removed and a type used to replace the+-- constrained type variable, it replaces the uses of that type variable+-- everywhere in the quantified type and removes the constraint.+replaceClassConstraint :: Type -> Type -> Type -> Q Type+replaceClassConstraint classType replacementType (ForallT vars preds typ) =+ let -- split the provided class into the typeclass and its arguments:+ --+ -- MonadFoo Int Bool+ -- ^^^^^^^^ ^^^^^^^^+ -- | |+ -- unappliedClassType classTypeArgs+ unappliedClassType = unappliedType classType+ classTypeArgs = typeArgs classType++ -- find the constraint that belongs to the typeclass by searching for the+ -- constaint with the same base type+ ([replacedPred], newPreds) = partition ((unappliedClassType ==) . unappliedType) preds++ -- Get the type vars that we need to replace, and match them with their+ -- replacements. Since we have already validated that classType is the+ -- same as replacedPred but missing one argument (via+ -- assertDerivableConstraint), we can easily align the types we need to+ -- replace with their instantiations.+ replacedVars = typeVarNames replacedPred+ replacementTypes = classTypeArgs ++ [replacementType]++ -- get the remaining vars in the forall quantification after stripping out+ -- the ones we’re replacing+ newVars = filter ((`notElem` replacedVars) . tyVarBndrName) vars++ -- actually perform the replacement substitution for each type var and its replacement+ replacedT = foldl' (flip $ uncurry substituteTypeVar) typ (zip replacedVars replacementTypes)+ in return $ ForallT newVars newPreds replacedT+replaceClassConstraint _ _ _ = fail "replaceClassConstraint: internal error; report a bug with the monad-mock package"++-- | Given the name of a type of kind @* -> *@, generate an 'Action' instance.+--+-- @+-- data FileSystemAction r where+-- ReadFile :: 'FilePath' -> FileSystemAction 'String'+-- WriteFile :: 'FilePath' -> 'String' -> FileSystemAction ()+-- deriving instance 'Eq' (FileSystemAction r)+-- deriving instance 'Show' (FileSystemAction r)+--+-- 'deriveAction' ''FileSystemAction+-- @+deriveAction :: Name -> Q [Dec]+deriveAction name = do+ info <- reify name+ (tyCon, dataCons) <- extractActionInfo info+ instanceDecl <- deriveAction' tyCon dataCons+ return [instanceDecl]+ where+ -- | Given an 'Info', asserts that it represents a type constructor and extracts+ -- its type and constructors.+ extractActionInfo :: Info -> Q (Type, [Con])+ extractActionInfo (TyConI (DataD _ actionName _ _ cons _))+ = return (ConT actionName, cons)+ extractActionInfo _+ = fail "deriveAction: expected type constructor"++-- | The implementation of 'deriveAction', given the type constructor for an+-- action and a list of constructors. This is useful for 'makeAction', since it+-- emits the type definition as part of its result, so there is no 'Name' bound+-- for 'deriveAction' to 'reify'.+deriveAction' :: Type -> [Con] -> Q Dec+deriveAction' tyCon dataCons = do+ eqActionDec <- deriveEqAction dataCons+ let instanceHead = ConT ''Action `AppT` tyCon+ return $ InstanceD Nothing [] instanceHead [eqActionDec]+ where+ -- | Given a list of constructors for a particular type, generates a definition+ -- of 'eqAction'.+ deriveEqAction :: [Con] -> Q Dec+ deriveEqAction cons = do+ clauses <- traverse deriveEqActionCase cons+ let fallthroughClause = Clause [WildP, WildP] (NormalB (ConE 'Nothing)) []+ clauses' = if length clauses > 1 then clauses ++ [fallthroughClause] else clauses+ return $ FunD 'eqAction clauses'++ -- | Given a single constructor for a particular type, generates one of the+ -- cases of 'eqAction'. Used by 'deriveEqAction'.+ deriveEqActionCase :: Con -> Q Clause+ deriveEqActionCase con = do+ binderNames <- replicateM (conNumArgs con) ((,) <$> newName "x" <*> newName "y")++ let name = conName con+ fstPat = ConP name (map (VarP . fst) binderNames)+ sndPat = ConP name (map (VarP . snd) binderNames)++ mkPairwiseComparison x y = VarE '(==) `AppE` VarE x `AppE` VarE y+ pairwiseComparisons = map (uncurry mkPairwiseComparison) binderNames++ bothComparisons x y = VarE '(&&) `AppE` x `AppE` y+ allComparisons = foldr bothComparisons (ConE 'True) pairwiseComparisons++ conditional = CondE allComparisons (ConE 'Just `AppE` ConE 'Refl) (ConE 'Nothing)++ return $ Clause [fstPat, sndPat] (NormalB conditional) []++-- | Extracts the 'Name' of a 'Con'.+conName :: Con -> Name+conName (NormalC name _) = name+conName (RecC name _) = name+conName (InfixC _ name _) = name+conName (ForallC _ _ con) = conName con+conName (GadtC [name] _ _) = name+conName (GadtC names _ _) = error $ "conName: internal error; non-singleton GADT constructor names: " ++ show names+conName (RecGadtC [name] _ _) = name+conName (RecGadtC names _ _) = error $ "conName: internal error; non-singleton GADT record constructor names: " ++ show names++-- | Extracts the number of arguments a 'Con' accepts.+conNumArgs :: Con -> Int+conNumArgs (NormalC _ bts) = length bts+conNumArgs (RecC _ vbts) = length vbts+conNumArgs (InfixC _ _ _) = 2+conNumArgs (ForallC _ _ con) = conNumArgs con+conNumArgs (GadtC _ bts _) = length bts+conNumArgs (RecGadtC _ vbts _) = length vbts++-- | Given a potentially applied type, like @T a b@, returns the base, unapplied+-- type name, like @T@.+unappliedType :: Type -> Type+unappliedType t@ConT{} = t+unappliedType (AppT t _) = unappliedType t+unappliedType other = error $ "unappliedType: internal error; expected plain applied type, given " ++ show other++-- | Like 'unappliedType', but extracts the 'Name' instead of 'Type'.+unappliedTypeName :: Type -> Name+unappliedTypeName t = let (ConT name) = unappliedType t in name++-- | The counterpart to 'unappliedType', this gets the arguments a type is+-- applied to.+typeArgs :: Type -> [Type]+typeArgs (AppT t a) = typeArgs t ++ [a]+typeArgs _ = []++-- | Given a function type, splits it into its components: quantified type+-- variables, constraint context, argument types, and result type. For+-- example, applying 'splitFnType' to+-- @forall a b c. (Foo a, Foo b, Bar c) => a -> b -> c@ produces+-- @([a, b, c], (Foo a, Foo b, Bar c), [a, b], c)@.+splitFnType :: Type -> ([TyVarBndr], Cxt, [Type], Type)+splitFnType (a `AppT` b `AppT` c) | a == ArrowT =+ let (tyVars, ctx, args, result) = splitFnType c+ in (tyVars, ctx, b:args, result)+splitFnType (ForallT tyVars ctx a) =+ let (tyVars', ctx', args, result) = splitFnType a+ in (tyVars ++ tyVars', ctx ++ ctx', args, result)+splitFnType a = ([], [], [], a)++fnTypeArity :: Type -> Int+fnTypeArity t = let (_, _, args, _) = splitFnType t in length args++-- | Substitutes a type variable with a type within a particular type. This is+-- used by 'replaceClassConstraint' to swap out the constrained and quantified+-- type variable with the type variable bound within the record declaration.+substituteTypeVar :: Name -> Type -> Type -> Type+substituteTypeVar initial replacement = doReplace+ where doReplace (ForallT a b t) = ForallT a b (doReplace t)+ doReplace (AppT a b) = AppT (doReplace a) (doReplace b)+ doReplace (SigT t k) = SigT (doReplace t) k+ doReplace t@(VarT n)+ | n == initial = replacement+ | otherwise = t+ doReplace other = other++-- | Given a type, returns a list of all of the unique type variables contained+-- within it.+typeVarNames :: Type -> [Name]+typeVarNames (VarT n) = [n]+typeVarNames (AppT a b) = nub (typeVarNames a ++ typeVarNames b)+typeVarNames _ = []++-- | Given any arbitrary 'TyVarBndr', gets its 'Name'.+tyVarBndrName :: TyVarBndr -> Name+tyVarBndrName (PlainTV name) = name+tyVarBndrName (KindedTV name _) = name++-- | Given some 'Info' about a class, get its methods as 'SigD' declarations.+classMethods :: Info -> Q [Dec]+classMethods (ClassI (ClassD _ _ _ _ methods) _) = return $ removeDefaultSigs methods+ where removeDefaultSigs = filter $ \case+ DefaultSigD{} -> False+ _ -> True+classMethods other = fail $ "classMethods: internal error; expected a class type, given " ++ show other
+ library/Control/Monad/Mock/TH/Internal/TypesQuasi.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS_HADDOCK hide, not-home #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++module Control.Monad.Mock.TH.Internal.TypesQuasi (ts) where++import Control.Monad ((<=<))+import Language.Haskell.Exts.Lexer+import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.SrcLoc+import Language.Haskell.Meta.Syntax.Translate (toType)+import Language.Haskell.TH.Instances ()+import Language.Haskell.TH.Syntax hiding (Loc)+import Language.Haskell.TH.Quote++-- | A quasi-quoter like the built-in @[t| ... |]@ quasi-quoter, but produces+-- a /list/ of types instead of a single type. Each type should be separated by+-- a comma.+--+-- >>> [ts| Bool, (), String |]+-- [ConT GHC.Types.Bool,ConT GHC.Tuple.(),ConT GHC.Base.String]+-- >>> [ts| Maybe Int, Monad m |]+-- [AppT (ConT GHC.Base.Maybe) (ConT GHC.Types.Int),AppT (ConT GHC.Base.Monad) (VarT m)]+ts :: QuasiQuoter+ts = QuasiQuoter+ { quoteExp = \str -> case parseTypesSplitOnCommas str of+ ParseOk tys -> lift =<< mapM resolveTypeNames tys+ ParseFailed _ msg -> fail msg+ , quotePat = error "ts can only be used in an expression context"+ , quoteType = error "ts can only be used in an expression context"+ , quoteDec = error "ts can only be used in an expression context"+ }++parseTypesSplitOnCommas :: String -> ParseResult [Type]+parseTypesSplitOnCommas = fmap (map toType) . mapM parseType <=< lexSplitOnCommas++lexSplitOnCommas :: String -> ParseResult [String]+lexSplitOnCommas str = splitOnSrcSpans str <$> lexSplittingCommas str++splitOnSrcSpans :: String -> [SrcSpan] -> [String]+splitOnSrcSpans str [] = [str]+splitOnSrcSpans str spans@(x:xs) = case x of+ SrcSpan { srcSpanStartLine = line, srcSpanStartColumn = col }+ | line > 1 ->+ let (l, _:ls) = break (== '\n') str+ (r:rs) = splitOnSrcSpans ls (map advanceLine spans)+ in (l ++ "\n" ++ r) : rs+ | col > 1 ->+ let (currentLs, nextLs) = span ((== line) . srcSpanStartLine) spans+ (c:cs) = str+ (r:rs) = splitOnSrcSpans cs (map advanceColumn currentLs ++ nextLs)+ in (c : r) : rs+ | otherwise ->+ let (currentLs, nextLs) = span ((== line) . srcSpanStartLine) xs+ (_:cs) = str+ in "" : splitOnSrcSpans cs (map advanceColumn currentLs ++ nextLs)+++advanceLine :: SrcSpan -> SrcSpan+advanceLine s@SrcSpan { srcSpanStartLine = line } = s { srcSpanStartLine = line - 1 }++advanceColumn :: SrcSpan -> SrcSpan+advanceColumn s@SrcSpan { srcSpanStartColumn = col } = s { srcSpanStartColumn = col - 1 }++lexSplittingCommas :: String -> ParseResult [SrcSpan]+lexSplittingCommas = fmap splittingCommas . lexTokenStream++splittingCommas :: [Loc Token] -> [SrcSpan]+splittingCommas = map loc . go+ where go [] = []+ go (x@Loc{ unLoc = Comma }:xs) = x : go xs+ go (Loc{ unLoc = LeftParen }:xs) = go $ skipUntil RightParen xs+ go (Loc{ unLoc = LeftSquare }:xs) = go $ skipUntil RightSquare xs+ go (Loc{ unLoc = LeftCurly }:xs) = go $ skipUntil RightCurly xs+ go (_:xs) = go xs++ skipUntil _ [] = []+ skipUntil d (Loc{ unLoc = LeftParen }:xs) = skipUntil d $ skipUntil RightParen xs+ skipUntil d (Loc{ unLoc = LeftSquare }:xs) = skipUntil d $ skipUntil RightSquare xs+ skipUntil d (Loc{ unLoc = LeftCurly }:xs) = skipUntil d $ skipUntil RightCurly xs+ skipUntil d (Loc{ unLoc = t }:xs)+ | t == d = xs+ | otherwise = skipUntil d xs++resolveTypeNames :: Type -> Q Type+resolveTypeNames (ConT nm) = ConT <$> resolveTypeName nm+resolveTypeNames (ForallT tyVars ctx t) = ForallT tyVars <$> mapM resolveTypeNames ctx <*> resolveTypeNames t+resolveTypeNames (AppT a b) = AppT <$> resolveTypeNames a <*> resolveTypeNames b+resolveTypeNames (SigT t k) = SigT <$> resolveTypeNames t <*> resolveTypeNames k+resolveTypeNames t@VarT{} = return t+resolveTypeNames t@PromotedT{} = return t+resolveTypeNames t@TupleT{} = return t+resolveTypeNames t@UnboxedTupleT{} = return t+resolveTypeNames t@ArrowT{} = return t+resolveTypeNames t@EqualityT = return t+resolveTypeNames t@ListT = return t+resolveTypeNames t@PromotedTupleT{} = return t+resolveTypeNames t@PromotedNilT = return t+resolveTypeNames t@PromotedConsT = return t+resolveTypeNames t@StarT = return t+resolveTypeNames t@ConstraintT = return t+resolveTypeNames t@LitT{} = return t+#if MIN_VERSION_template_haskell(2,11,0)+resolveTypeNames (InfixT a n b) = InfixT <$> resolveTypeNames a <*> resolveTypeName n <*> resolveTypeNames b+resolveTypeNames (UInfixT a n b) = UInfixT <$> resolveTypeNames a <*> resolveTypeName n <*> resolveTypeNames b+resolveTypeNames (ParensT t) = ParensT <$> resolveTypeNames t+resolveTypeNames t@WildCardT = return t+#endif++resolveTypeName :: Name -> Q Name+resolveTypeName (Name (OccName str) NameS) = lookupTypeName str >>= \case+ Just nm -> return nm+ Nothing -> fail $ "unbound type name ‘" ++ str ++ "’"+resolveTypeName nm = return nm
monad-mock.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: monad-mock-version: 0.1.0.0+version: 0.1.1.0 synopsis: A monad transformer for mocking mtl-style typeclasses description: This package provides a monad transformer that helps create “mocks” of @mtl@-style typeclasses, intended for use in unit tests. A mock can be@@ -23,6 +23,8 @@ cabal-version: >= 1.10 extra-source-files:+ CHANGELOG.md+ LICENSE package.yaml README.md stack.yaml@@ -34,17 +36,23 @@ library hs-source-dirs: library- default-extensions: DefaultSignatures FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses ScopedTypeVariables StandaloneDeriving TypeFamilies TypeOperators+ default-extensions: DefaultSignatures FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeOperators ghc-options: -Wall build-depends: base >= 4.9.0.0 && < 5 , constraints >= 0.3.1 , exceptions >= 0.6+ , haskell-src-exts+ , haskell-src-meta+ , th-orphans , monad-control >= 1.0.0.0 && < 2 , mtl+ , template-haskell >= 2.11.0.0 && < 2.12 , transformers-base exposed-modules: Control.Monad.Mock+ Control.Monad.Mock.TH+ Control.Monad.Mock.TH.Internal.TypesQuasi default-language: Haskell2010 test-suite monad-stub-test-suite@@ -52,7 +60,7 @@ main-is: Main.hs hs-source-dirs: test-suite- default-extensions: DefaultSignatures FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses ScopedTypeVariables StandaloneDeriving TypeFamilies TypeOperators+ default-extensions: DefaultSignatures FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses ScopedTypeVariables StandaloneDeriving TupleSections TypeFamilies TypeOperators ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N build-depends: base
package.yaml view
@@ -1,5 +1,5 @@ name: monad-mock-version: 0.1.0.0+version: 0.1.1.0 category: Testing synopsis: A monad transformer for mocking mtl-style typeclasses description: |@@ -17,6 +17,8 @@ github: cjdev/monad-mock extra-source-files:+- CHANGELOG.md+- LICENSE - package.yaml - README.md - stack.yaml@@ -32,6 +34,7 @@ - MultiParamTypeClasses - ScopedTypeVariables - StandaloneDeriving+- TupleSections - TypeFamilies - TypeOperators @@ -40,8 +43,12 @@ - base >= 4.9.0.0 && < 5 - constraints >= 0.3.1 - exceptions >= 0.6+ - haskell-src-exts+ - haskell-src-meta+ - th-orphans - monad-control >= 1.0.0.0 && < 2 - mtl+ - template-haskell >= 2.11.0.0 && < 2.12 - transformers-base source-dirs: library
test-suite/Control/Monad/MockSpec.hs view
@@ -1,34 +1,21 @@-module Control.Monad.MockSpec where+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} +module Control.Monad.MockSpec (spec) where+ import Prelude hiding (readFile, writeFile) import Control.Exception (evaluate) import Data.Function ((&))-import Data.Type.Equality ((:~:)(..)) import Test.Hspec import Control.Monad.Mock+import Control.Monad.Mock.TH class Monad m => MonadFileSystem m where readFile :: FilePath -> m String writeFile :: FilePath -> String -> m ()--data FileSystemAction r where- ReadFile :: FilePath -> FileSystemAction String- WriteFile :: FilePath -> String -> FileSystemAction ()-deriving instance Eq (FileSystemAction r)-deriving instance Show (FileSystemAction r)--instance Action FileSystemAction where- eqAction (ReadFile a) (ReadFile b)- = if a == b then Just Refl else Nothing- eqAction (WriteFile a b) (WriteFile c d)- = if a == c && b == d then Just Refl else Nothing- eqAction _ _ = Nothing--instance Monad m => MonadFileSystem (MockT FileSystemAction m) where- readFile a = mockAction "readFile" (ReadFile a)- writeFile a b = mockAction "writeFile" (WriteFile a b)+makeAction "FileSystemAction" [ts| MonadFileSystem |] copyFileAndReturn :: MonadFileSystem m => FilePath -> FilePath -> m String copyFileAndReturn a b = do