├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── library └── Control │ └── Monad │ ├── Mock.hs │ └── Mock │ ├── TH.hs │ └── TH │ └── Internal │ └── TypesQuasi.hs ├── package.yaml ├── stack.yaml └── test-suite ├── Control └── Monad │ └── MockSpec.hs └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | # Stack uses this directory as scratch space. 2 | /.stack-work/ 3 | # Stack generates the Cabal file from `package.yaml` through hpack. 4 | /*.cabal 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | cache: 4 | directories: 5 | - $HOME/.stack 6 | - .stack-work 7 | 8 | # The different configurations we want to test. 9 | # 10 | # We set the compiler values here to tell Travis to use a different 11 | # cache file per set of arguments. 12 | matrix: 13 | include: 14 | - env: ARGS="--resolver lts-6" 15 | compiler: ": #stack 7.10.3" 16 | addons: { apt: { packages: [libgmp-dev] } } 17 | 18 | - env: ARGS="--resolver lts-7" 19 | compiler: ": #stack 8.0.1" 20 | addons: { apt: { packages: [libgmp-dev] } } 21 | 22 | - env: ARGS="--resolver lts-8" 23 | compiler: ": #stack 8.0.2" 24 | addons: { apt: { packages: [libgmp-dev] } } 25 | 26 | - env: ARGS="--resolver nightly-2017-07-31" 27 | compiler: ": #stack 8.2.1" 28 | addons: { apt: { packages: [libgmp-dev] } } 29 | 30 | - env: ARGS="--resolver nightly" 31 | compiler: ": #stack nightly" 32 | addons: { apt: { packages: [libgmp-dev] } } 33 | 34 | allow_failures: 35 | # Nightly builds are allowed to fail 36 | - env: ARGS="--resolver nightly" 37 | 38 | before_install: 39 | # Using compiler above sets CC to an invalid value, so unset it 40 | - unset CC 41 | 42 | # Download and unpack the stack executable 43 | - export PATH=$HOME/.local/bin:$PATH 44 | - mkdir -p ~/.local/bin 45 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 46 | 47 | install: 48 | - stack --no-terminal --install-ghc $ARGS build happy 49 | - stack --no-terminal $ARGS test --bench --only-dependencies 50 | 51 | script: 52 | - stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options=-Werror 53 | 54 | before_cache: 55 | - stack --no-terminal $ARGS clean monad-mock 56 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 0.2.0.0 (September 14th, 2017) 2 | 3 | - `Control.Monad.Mock.TH` is smarter about deriving instances for classes with superclass contexts: the derived context is based on superclasses rather than being hardcoded to `Monad m`. 4 | 5 | ## 0.1.1.2 (August 1st, 2017) 6 | 7 | - Added support for GHC 7.10. 8 | 9 | ## 0.1.1.1 (June 28th, 2017) 10 | 11 | - Added support for GHC 8.2. 12 | - Includes some minor documentation fixes. 13 | 14 | ## 0.1.1.0 (June 27th, 2017) 15 | 16 | - Added `Control.Monad.Mock.TH`, which provides functions for automatically generating actions using Template Haskell. 17 | 18 | ## 0.1.0.0 (June 23rd, 2017) 19 | 20 | - Initial release 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017 CJ Affiliate by Conversant 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any purpose 4 | with or without fee is hereby granted, provided that the above copyright notice 5 | and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 8 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND 9 | FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 10 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS 11 | OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER 12 | TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF 13 | THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # monad-mock [![Build Status](https://travis-ci.org/cjdev/monad-mock.svg?branch=master)](https://travis-ci.org/cjdev/monad-mock) 2 | 3 | `monad-mock` is a Haskell package that provides a monad transformer to help 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. 4 | 5 | For example, imagine a `MonadFileSystem` typeclass, which describes a class of 6 | monads that may perform filesystem operations: 7 | 8 | ```haskell 9 | class Monad m => MonadFileSystem m where 10 | readFile :: FilePath -> m String 11 | writeFile :: FilePath -> String -> m () 12 | ``` 13 | 14 | Using `MockT`, it’s possible to test computations that use `MonadFileSystem` 15 | in a completely pure way: 16 | 17 | ```haskell 18 | copyFile :: MonadFileSystem m => FilePath -> FilePath -> m () 19 | copyFile a b = do 20 | x <- readFile a 21 | writeFile b x 22 | 23 | makeMock "FileSystemAction" [ts| MonadFileSystem |] 24 | 25 | spec = describe "copyFile" $ 26 | it "reads a file and writes its contents to another file" $ 27 | evaluate $ copyFile "foo.txt" "bar.txt" 28 | & runMock [ ReadFile "foo.txt" :-> "contents" 29 | , WriteFile "bar.txt" "contents" :-> () ] 30 | ``` 31 | 32 | For more information, [see the documentation on Hackage][monad-mock]. 33 | 34 | [monad-mock]: https://hackage.haskell.org/package/monad-mock 35 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /library/Control/Monad/Mock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | {-| 5 | This module provides a monad transformer that helps create “mocks” of 6 | @mtl@-style typeclasses, intended for use in unit tests. A mock can be 7 | executed by providing a sequence of expected monadic calls and their results, 8 | and the mock will verify that the computation conforms to the expectation. 9 | 10 | For example, imagine a @MonadFileSystem@ typeclass, which describes a class of 11 | monads that may perform filesystem operations: 12 | 13 | @ 14 | class 'Monad' m => MonadFileSystem m where 15 | readFile :: 'FilePath' -> m 'String' 16 | writeFile :: 'FilePath' -> 'String' -> m () 17 | @ 18 | 19 | Using 'MockT', it’s possible to test computations that use @MonadFileSystem@ 20 | in a completely pure way: 21 | 22 | @ 23 | copyFile :: MonadFileSystem m => 'FilePath' -> 'FilePath' -> m () 24 | copyFile a b = do 25 | x <- readFile a 26 | writeFile b x 27 | 28 | spec = describe "copyFile" '$' 29 | it "reads a file and writes its contents to another file" '$' 30 | 'Control.Exception.evaluate' '$' copyFile "foo.txt" "bar.txt" 31 | 'Data.Function.&' 'runMock' [ ReadFile "foo.txt" ':->' "contents" 32 | , WriteFile "bar.txt" "contents" ':->' () ] 33 | @ 34 | 35 | To make the above code work, all you have to do is write a small GADT that 36 | represents typeclass method calls and implement the 'Action' typeclass: 37 | 38 | @ 39 | data FileSystemAction r where 40 | ReadFile :: 'FilePath' -> FileSystemAction 'String' 41 | WriteFile :: 'FilePath' -> 'String' -> FileSystemAction () 42 | deriving instance 'Eq' (FileSystemAction r) 43 | deriving instance 'Show' (FileSystemAction r) 44 | 45 | instance 'Action' FileSystemAction where 46 | 'eqAction' (ReadFile a) (ReadFile b) 47 | = if a '==' b then 'Just' 'Refl' else 'Nothing' 48 | 'eqAction' (WriteFile a b) (WriteFile c d) 49 | = if a '==' c && b '==' d then 'Just' 'Refl' else 'Nothing' 50 | 'eqAction' _ _ = 'Nothing' 51 | @ 52 | 53 | Then, just write a @MonadFileSystem@ instance for 'MockT': 54 | 55 | @ 56 | instance 'Monad' m => MonadFileSystem ('MockT' FileSystemAction m) where 57 | readFile a = 'mockAction' "readFile" (ReadFile a) 58 | writeFile a b = 'mockAction' "writeFile" (WriteFile a b) 59 | @ 60 | 61 | For some Template Haskell functions that eliminate the need to write the above 62 | boilerplate, look at 'Control.Monad.Mock.TH.makeAction' from 63 | "Control.Monad.Mock.TH". 64 | -} 65 | module Control.Monad.Mock 66 | ( -- * The MockT monad transformer 67 | MockT 68 | , Mock 69 | , runMockT 70 | , runMock 71 | , mockAction 72 | 73 | -- * Actions and actions with results 74 | , Action(..) 75 | , WithResult(..) 76 | ) where 77 | 78 | import Control.Monad.Base (MonadBase) 79 | import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask) 80 | import Control.Monad.Cont (MonadCont) 81 | import Control.Monad.Except (MonadError) 82 | import Control.Monad.IO.Class (MonadIO) 83 | import Control.Monad.Reader (MonadReader) 84 | import Control.Monad.State (StateT, MonadState(..), runStateT) 85 | import Control.Monad.Trans (MonadTrans(..)) 86 | import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl(..), MonadTransControl(..), defaultLiftBaseWith, defaultLiftWith, defaultRestoreM, defaultRestoreT) 87 | import Control.Monad.Writer (MonadWriter) 88 | import Data.Constraint ((:-), (\\)) 89 | import Data.Constraint.Forall (ForallF, instF) 90 | import Data.Functor.Identity (Identity, runIdentity) 91 | import Data.Type.Equality ((:~:)(..)) 92 | 93 | error' :: String -> a 94 | #if MIN_VERSION_base(4,9,0) 95 | error' = errorWithoutStackTrace 96 | #else 97 | error' = error 98 | #endif 99 | 100 | -- | A class of types that represent typeclass method calls. The type must be of 101 | -- kind @* -> *@, and its type parameter should represent type of the method’s 102 | -- return type. 103 | class Action f where 104 | -- | Compares two 'Action's for equality, and produces a witness of type 105 | -- equality if the two actions are, in fact, equal. 106 | eqAction :: f a -> f b -> Maybe (a :~: b) 107 | 108 | -- | Converts an 'Action' to a 'String', which will be used when displaying 109 | -- mock failures. 110 | -- 111 | -- The default implementation of 'showAction' just uses 'Show', assuming there 112 | -- is an instance @forall a. 'Show' (f a)@. This instance can be derived by 113 | -- GHC using a standalone @deriving@ clause. 114 | showAction :: f a -> String 115 | 116 | default showAction :: ForallF Show f => f a -> String 117 | showAction = showAction' where 118 | -- This needs to be in a separate binding, since for some reason GHC 119 | -- versions prior to 8.0.2 choke on this if it’s inlined into the definition 120 | -- of showAction. 121 | showAction' :: forall g a. ForallF Show g => g a -> String 122 | showAction' x = show x \\ (instF :: ForallF Show g :- Show (g a)) 123 | 124 | -- | Represents both an expected call (an 'Action') and its expected result. 125 | data WithResult f where 126 | (:->) :: f r -> r -> WithResult f 127 | 128 | -- | A monad transformer for creating mock instances of typeclasses. In @'MockT' 129 | -- f m a@, @f@ should be an 'Action', which should be a GADT that represents a 130 | -- reified version of typeclass method calls. 131 | newtype MockT f m a = MockT (StateT [WithResult f] m a) 132 | deriving ( Functor, Applicative, Monad, MonadTrans, MonadIO, MonadBase b 133 | , MonadReader r, MonadCont, MonadError e, MonadWriter w 134 | , MonadCatch, MonadThrow, MonadMask ) 135 | 136 | instance MonadState s m => MonadState s (MockT f m) where 137 | get = lift get 138 | put = lift . put 139 | state = lift . state 140 | 141 | instance MonadTransControl (MockT f) where 142 | type StT (MockT f) a = StT (StateT [WithResult f]) a 143 | liftWith = defaultLiftWith MockT (\(MockT x) -> x) 144 | restoreT = defaultRestoreT MockT 145 | 146 | instance MonadBaseControl b m => MonadBaseControl b (MockT f m) where 147 | type StM (MockT f m) a = ComposeSt (MockT f) m a 148 | liftBaseWith = defaultLiftBaseWith 149 | restoreM = defaultRestoreM 150 | 151 | type Mock f = MockT f Identity 152 | 153 | -- | Runs a 'MockT' computation given an expected list of calls and results. If 154 | -- any method is called during the extent of the computation that is unexpected, 155 | -- an exception will be thrown. Additionally, if the computation terminates 156 | -- without making /all/ of the expected calls, an exception is raised. 157 | runMockT :: forall f m a. (Action f, Monad m) => [WithResult f] -> MockT f m a -> m a 158 | runMockT actions (MockT x) = runStateT x actions >>= \case 159 | (r, []) -> return r 160 | (_, remainingActions) -> error' 161 | $ "runMockT: expected the following unexecuted actions to be run:\n" 162 | ++ unlines (map (\(action :-> _) -> " " ++ showAction action) remainingActions) 163 | 164 | runMock :: forall f a. Action f => [WithResult f] -> Mock f a -> a 165 | runMock actions x = runIdentity $ runMockT actions x 166 | 167 | -- | Logs a method call within a mock. 168 | mockAction :: (Action f, Monad m) => String -> f r -> MockT f m r 169 | mockAction fnName action = MockT $ get >>= \case 170 | [] -> error' 171 | $ "runMockT: expected end of program, called " ++ fnName ++ "\n" 172 | ++ " given action: " ++ showAction action ++ "\n" 173 | (action' :-> r) : actions 174 | | Just Refl <- action `eqAction` action' -> put actions >> return r 175 | | otherwise -> error' 176 | $ "runMockT: argument mismatch in " ++ fnName ++ "\n" 177 | ++ " given: " ++ showAction action ++ "\n" 178 | ++ " expected: " ++ showAction action' ++ "\n" 179 | -------------------------------------------------------------------------------- /library/Control/Monad/Mock/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | #if MIN_VERSION_GLASGOW_HASKELL(8,0,1,0) 4 | {-# LANGUAGE TemplateHaskellQuotes #-} 5 | #else 6 | {-# LANGUAGE TemplateHaskell #-} 7 | #endif 8 | 9 | {-| 10 | This module provides Template Haskell functions for automatically generating 11 | types representing typeclass methods for use with "Control.Monad.Mock". The 12 | resulting datatypes can be used with 'Control.Monad.Mock.runMock' or 13 | 'Control.Monad.Mock.runMockT' to mock out functionality in unit tests. 14 | 15 | The primary interface to this module is the 'makeAction' function, which 16 | generates an action GADT given a list of mtl-style typeclass constraints. For 17 | example, consider a typeclass that encodes side-effectful monadic operations: 18 | 19 | @ 20 | class 'Monad' m => MonadFileSystem m where 21 | readFile :: 'FilePath' -> m 'String' 22 | writeFile :: 'FilePath' -> 'String' -> m () 23 | @ 24 | 25 | The typeclass has an obvious, straightforward instance for 'IO'. However, one 26 | of the main value of using a typeclass is that a alternate, pure instance may 27 | be provided for unit tests, which is what 'MockT' provides. Therefore, one 28 | might use 'makeAction' to automatically generate the necessary datatype and 29 | instances: 30 | 31 | @ 32 | 'makeAction' \"FileSystemAction\" ['ts'| MonadFileSystem |] 33 | @ 34 | 35 | This generates three things: 36 | 37 | 1. A @FileSystemAction@ GADT with constructors that correspond to the 38 | methods of @MonadFileSystem@. 39 | 40 | 2. An 'Action' instance for @FileSystemAction@. 41 | 42 | 3. A @MonadFileSystem@ instance for @'MockT' FileSystemAction m@. 43 | 44 | The generated code effectively looks like this: 45 | 46 | @ 47 | data FileSystemAction r where 48 | ReadFile :: 'FilePath' -> FileSystemAction 'String' 49 | WriteFile :: 'FilePath' -> 'String' -> FileSystemAction () 50 | deriving instance 'Eq' (FileSystemAction r) 51 | deriving instance 'Show' (FileSystemAction r) 52 | 53 | instance 'Action' FileSystemAction where 54 | 'eqAction' (ReadFile a) (ReadFile b) 55 | = if a '==' b then 'Just' 'Refl' else 'Nothing' 56 | 'eqAction' (WriteFile a b) (WriteFile c d) 57 | = if a '==' c && b '==' d then 'Just' 'Refl' else 'Nothing' 58 | 'eqAction' _ _ = 'Nothing' 59 | 60 | instance 'Monad' m => MonadFileSystem ('MockT' FileSystemAction m) where 61 | readFile a = 'mockAction' "readFile" (ReadFile a) 62 | writeFile a b = 'mockAction' "writeFile" (WriteFile a b) 63 | @ 64 | 65 | This can then be used in tandem with 'Control.Monad.Mock.runMock' to unit-test 66 | a function that interacts with the file system in a completely pure way: 67 | 68 | @ 69 | copyFile :: MonadFileSystem m => 'FilePath' -> 'FilePath' -> m () 70 | copyFile a b = do 71 | x <- readFile a 72 | writeFile b x 73 | 74 | spec = describe "copyFile" '$' 75 | it "reads a file and writes its contents to another file" '$' 76 | 'Control.Exception.evaluate' '$' copyFile "foo.txt" "bar.txt" 77 | 'Data.Function.&' 'Control.Monad.Mock.runMock' [ ReadFile "foo.txt" ':->' "contents" 78 | , WriteFile "bar.txt" "contents" ':->' () ] 79 | @ 80 | -} 81 | module Control.Monad.Mock.TH (makeAction, deriveAction, ts) where 82 | 83 | import Control.Monad (replicateM, when, zipWithM) 84 | import Data.Char (toUpper) 85 | import Data.Foldable (traverse_) 86 | import Data.List (foldl', nub, partition) 87 | import Data.Type.Equality ((:~:)(..)) 88 | import GHC.Exts (Constraint) 89 | import Language.Haskell.TH 90 | 91 | import Control.Monad.Mock (Action(..), MockT, mockAction) 92 | import Control.Monad.Mock.TH.Internal.TypesQuasi (ts) 93 | 94 | -- | Given a list of monadic typeclass constraints of kind @* -> 'Constraint'@, 95 | -- generate a type with an 'Action' instance with constructors that have the 96 | -- same types as the methods. 97 | -- 98 | -- @ 99 | -- class 'Monad' m => MonadFileSystem m where 100 | -- readFile :: 'FilePath' -> m 'String' 101 | -- writeFile :: 'FilePath' -> 'String' -> m () 102 | -- 103 | -- 'makeAction' "FileSystemAction" ['ts'| MonadFileSystem |] 104 | -- @ 105 | makeAction :: String -> Cxt -> Q [Dec] 106 | makeAction actionNameStr classTs = do 107 | traverse_ assertDerivableConstraint classTs 108 | 109 | actionParamName <- newName "r" 110 | let actionName = mkName actionNameStr 111 | actionTypeCon = ConT actionName 112 | actionTypeParam = VarT actionParamName 113 | 114 | classInfos <- traverse reify (map unappliedTypeName classTs) 115 | methods <- traverse classMethods classInfos 116 | actionCons <- concat <$> zipWithM (methodsToConstructors actionTypeCon actionTypeParam) classTs methods 117 | 118 | let actionDec = DataD' [] actionName [PlainTV actionParamName] actionCons 119 | mkStandaloneDec derivT = standaloneDeriveD' [] (derivT `AppT` (actionTypeCon `AppT` VarT actionParamName)) 120 | standaloneDecs = [mkStandaloneDec (ConT ''Eq), mkStandaloneDec (ConT ''Show)] 121 | actionInstanceDec <- deriveAction' actionTypeCon actionCons 122 | classInstanceDecs <- zipWithM (mkInstance actionTypeCon) classTs methods 123 | 124 | return $ [actionDec] ++ standaloneDecs ++ [actionInstanceDec] ++ classInstanceDecs 125 | where 126 | -- | Ensures that a provided constraint is something monad-mock can actually 127 | -- derive an instance for. Specifically, it must be a constraint of kind 128 | -- @* -> 'Constraint'@, and anything else is invalid. 129 | assertDerivableConstraint :: Type -> Q () 130 | assertDerivableConstraint classType = do 131 | info <- reify $ unappliedTypeName classType 132 | (ClassD _ _ classVars _ _) <- case info of 133 | ClassI dec _ -> return dec 134 | _ -> fail $ "makeAction: expected a constraint, given ‘" ++ show (ppr classType) ++ "’" 135 | 136 | let classArgs = typeArgs classType 137 | let mkClassKind vars = foldr (\a b -> AppT (AppT ArrowT a) b) (ConT ''Constraint) (reverse varKinds) 138 | where varKinds = map (\(KindedTV _ k) -> k) vars 139 | constraintStr = show (ppr (ConT ''Constraint)) 140 | 141 | when (length classArgs > length classVars) $ 142 | fail $ "makeAction: too many arguments for class\n" 143 | ++ " in: " ++ show (ppr classType) ++ "\n" 144 | ++ " for class of kind: " ++ show (ppr (mkClassKind classVars)) 145 | 146 | when (length classArgs == length classVars) $ 147 | fail $ "makeAction: cannot derive instance for fully saturated constraint\n" 148 | ++ " in: " ++ show (ppr classType) ++ "\n" 149 | ++ " expected: (* -> *) -> " ++ constraintStr ++ "\n" 150 | ++ " given: " ++ constraintStr 151 | 152 | when (length classArgs < length classVars - 1) $ 153 | fail $ "makeAction: cannot derive instance for multi-parameter typeclass\n" 154 | ++ " in: " ++ show (ppr classType) ++ "\n" 155 | ++ " expected: (* -> *) -> " ++ constraintStr ++ "\n" 156 | ++ " given: " ++ show (ppr (mkClassKind $ drop (length classArgs) classVars)) 157 | 158 | -- | Converts a class’s methods to constructors for an action type. There 159 | -- are two operations involved in this conversion: 160 | -- 161 | -- 1. Capitalize the first character of the method name to make it a valid 162 | -- data constructor name. 163 | -- 164 | -- 2. Replace the type variable bound by the typeclass constraint. To 165 | -- explain this step, consider the following typeclass: 166 | -- 167 | -- > class Monad m => MonadFoo m where 168 | -- > foo :: String -> m Foo 169 | -- 170 | -- The signature for @foo@ is really as follows: 171 | -- 172 | -- > forall m. MonadFoo m => String -> m Foo 173 | -- 174 | -- However, when converted to a GADT, we want it to look like this: 175 | -- 176 | -- > data SomeAction f where 177 | -- > Foo :: String -> SomeAction Foo 178 | -- 179 | -- Specifically, we want to remove the @m@ quantified type variable, 180 | -- and we want to replace it with the @SomeAction@ type constructor 181 | -- itself. 182 | -- 183 | -- To accomplish this, 'methodToConstructors' accepts two 'Type's, 184 | -- where the first is the action type constructor, and the second is 185 | -- the constraint which must be removed. 186 | methodsToConstructors :: Type -> Type -> Type -> [Dec] -> Q [Con] 187 | methodsToConstructors actionConT actionParamT classT = traverse (methodToConstructor actionConT actionParamT classT) 188 | 189 | -- | Converts a single class method into a constructor for an action type. 190 | methodToConstructor :: Type -> Type -> Type -> Dec -> Q Con 191 | methodToConstructor actionConT actionParamT classT (SigD name typ) = do 192 | let constructorName = methodNameToConstructorName name 193 | newT <- replaceClassConstraint classT actionConT typ 194 | let (tyVars, ctx, argTs, resultT) = splitFnType newT 195 | gadtCon = gadtC' constructorName [actionParamT] argTs resultT 196 | return $ ForallC tyVars ctx gadtCon 197 | methodToConstructor _ _ _ _ = fail "methodToConstructor: internal error; report a bug with the monad-mock package" 198 | 199 | -- | Converts an ordinary term-level identifier, which starts with a 200 | -- lower-case letter, to a data constructor, which starts with an upper- 201 | -- case letter. 202 | methodNameToConstructorName :: Name -> Name 203 | methodNameToConstructorName name = mkName (toUpper c : cs) 204 | where (c:cs) = nameBase name 205 | 206 | mkInstance :: Type -> Type -> [Dec] -> Q Dec 207 | mkInstance actionT classT methodSigs = do 208 | mVar <- newName "m" 209 | 210 | -- In order to calculate the constraints on the instance, we need to look 211 | -- at the superclasses of the class we're deriving an instance for. For 212 | -- example, given some class: 213 | -- 214 | -- class (AsSomething e, MonadError e m) => MonadFoo e m | m -> e 215 | -- 216 | -- ...if we are asked to derive an instance for @MonadFoo Something@, then 217 | -- we need to generate an instance with a constraint like the following: 218 | -- 219 | -- instance (AsSomething Something, MonadError Something m) 220 | -- => MonadFoo Something (MockT Action m) 221 | -- 222 | -- To do that, we just need to look at the binders of the class, then 223 | -- use that to build a substitution that can be applied to the superclass 224 | -- constraints. 225 | (ClassI (ClassD classContext _ classBindVars _ _) _) <- reify $ unappliedTypeName classT 226 | let classBinds = map tyVarBndrName classBindVars 227 | instanceBinds = typeArgs classT ++ [VarT mVar] 228 | classBindsToInstanceBinds = zip classBinds instanceBinds 229 | contextSubFns = map (uncurry substituteTypeVar) classBindsToInstanceBinds 230 | instanceContext = foldr map classContext contextSubFns 231 | 232 | let instanceHead = classT `AppT` (ConT ''MockT `AppT` actionT `AppT` VarT mVar) 233 | methodImpls <- traverse mkInstanceMethod methodSigs 234 | 235 | return $ instanceD' instanceContext instanceHead methodImpls 236 | 237 | mkInstanceMethod :: Dec -> Q Dec 238 | mkInstanceMethod (SigD name typ) = do 239 | let constructorName = methodNameToConstructorName name 240 | arity = fnTypeArity typ 241 | 242 | argNames <- replicateM arity (newName "x") 243 | let pats = map VarP argNames 244 | conCall = foldl' AppE (ConE constructorName) (map VarE argNames) 245 | mockCall = VarE 'mockAction `AppE` LitE (StringL $ nameBase name) `AppE` conCall 246 | 247 | return $ FunD name [Clause pats (NormalB mockCall) []] 248 | mkInstanceMethod _ = fail "mkInstanceMethod: internal error; report a bug with the monad-mock package" 249 | 250 | -- | Implements the class constraint replacement functionality as described in 251 | -- the documentation for 'methodsToConstructors'. Given a type that represents 252 | -- the typeclass whose constraint must be removed and a type used to replace the 253 | -- constrained type variable, it replaces the uses of that type variable 254 | -- everywhere in the quantified type and removes the constraint. 255 | replaceClassConstraint :: Type -> Type -> Type -> Q Type 256 | replaceClassConstraint classType replacementType (ForallT vars preds typ) = 257 | let -- split the provided class into the typeclass and its arguments: 258 | -- 259 | -- MonadFoo Int Bool 260 | -- ^^^^^^^^ ^^^^^^^^ 261 | -- | | 262 | -- unappliedClassType classTypeArgs 263 | unappliedClassType = unappliedType classType 264 | classTypeArgs = typeArgs classType 265 | 266 | -- find the constraint that belongs to the typeclass by searching for the 267 | -- constaint with the same base type 268 | ([replacedPred], newPreds) = partition ((unappliedClassType ==) . unappliedType) preds 269 | 270 | -- Get the type vars that we need to replace, and match them with their 271 | -- replacements. Since we have already validated that classType is the 272 | -- same as replacedPred but missing one argument (via 273 | -- assertDerivableConstraint), we can easily align the types we need to 274 | -- replace with their instantiations. 275 | replacedVars = typeVarNames replacedPred 276 | replacementTypes = classTypeArgs ++ [replacementType] 277 | 278 | -- get the remaining vars in the forall quantification after stripping out 279 | -- the ones we’re replacing 280 | newVars = filter ((`notElem` replacedVars) . tyVarBndrName) vars 281 | 282 | -- actually perform the replacement substitution for each type var and its replacement 283 | replacedT = foldl' (flip $ uncurry substituteTypeVar) typ (zip replacedVars replacementTypes) 284 | in return $ ForallT newVars newPreds replacedT 285 | replaceClassConstraint _ _ _ = fail "replaceClassConstraint: internal error; report a bug with the monad-mock package" 286 | 287 | -- | Given the name of a type of kind @* -> *@, generate an 'Action' instance. 288 | -- 289 | -- @ 290 | -- data FileSystemAction r where 291 | -- ReadFile :: 'FilePath' -> FileSystemAction 'String' 292 | -- WriteFile :: 'FilePath' -> 'String' -> FileSystemAction () 293 | -- deriving instance 'Eq' (FileSystemAction r) 294 | -- deriving instance 'Show' (FileSystemAction r) 295 | -- 296 | -- 'deriveAction' ''FileSystemAction 297 | -- @ 298 | deriveAction :: Name -> Q [Dec] 299 | deriveAction name = do 300 | info <- reify name 301 | (tyCon, dataCons) <- extractActionInfo info 302 | instanceDecl <- deriveAction' tyCon dataCons 303 | return [instanceDecl] 304 | where 305 | -- | Given an 'Info', asserts that it represents a type constructor and extracts 306 | -- its type and constructors. 307 | extractActionInfo :: Info -> Q (Type, [Con]) 308 | extractActionInfo (TyConI (DataD' _ actionName _ cons)) 309 | = return (ConT actionName, cons) 310 | extractActionInfo _ 311 | = fail "deriveAction: expected type constructor" 312 | 313 | -- | The implementation of 'deriveAction', given the type constructor for an 314 | -- action and a list of constructors. This is useful for 'makeAction', since it 315 | -- emits the type definition as part of its result, so there is no 'Name' bound 316 | -- for 'deriveAction' to 'reify'. 317 | deriveAction' :: Type -> [Con] -> Q Dec 318 | deriveAction' tyCon dataCons = do 319 | eqActionDec <- deriveEqAction dataCons 320 | let instanceHead = ConT ''Action `AppT` tyCon 321 | return $ instanceD' [] instanceHead [eqActionDec] 322 | where 323 | -- | Given a list of constructors for a particular type, generates a definition 324 | -- of 'eqAction'. 325 | deriveEqAction :: [Con] -> Q Dec 326 | deriveEqAction cons = do 327 | clauses <- traverse deriveEqActionCase cons 328 | let fallthroughClause = Clause [WildP, WildP] (NormalB (ConE 'Nothing)) [] 329 | clauses' = if length clauses > 1 then clauses ++ [fallthroughClause] else clauses 330 | return $ FunD 'eqAction clauses' 331 | 332 | -- | Given a single constructor for a particular type, generates one of the 333 | -- cases of 'eqAction'. Used by 'deriveEqAction'. 334 | deriveEqActionCase :: Con -> Q Clause 335 | deriveEqActionCase con = do 336 | binderNames <- replicateM (conNumArgs con) ((,) <$> newName "x" <*> newName "y") 337 | 338 | let name = conName con 339 | fstPat = ConP name (map (VarP . fst) binderNames) 340 | sndPat = ConP name (map (VarP . snd) binderNames) 341 | 342 | mkPairwiseComparison x y = VarE '(==) `AppE` VarE x `AppE` VarE y 343 | pairwiseComparisons = map (uncurry mkPairwiseComparison) binderNames 344 | 345 | bothComparisons x y = VarE '(&&) `AppE` x `AppE` y 346 | allComparisons = foldr bothComparisons (ConE 'True) pairwiseComparisons 347 | 348 | conditional = CondE allComparisons (ConE 'Just `AppE` ConE 'Refl) (ConE 'Nothing) 349 | 350 | return $ Clause [fstPat, sndPat] (NormalB conditional) [] 351 | 352 | -- | Extracts the 'Name' of a 'Con'. 353 | conName :: Con -> Name 354 | conName (NormalC name _) = name 355 | conName (RecC name _) = name 356 | conName (InfixC _ name _) = name 357 | conName (ForallC _ _ con) = conName con 358 | #if MIN_VERSION_template_haskell(2,11,0) 359 | conName (GadtC [name] _ _) = name 360 | conName (GadtC names _ _) = error $ "conName: internal error; non-singleton GADT constructor names: " ++ show names 361 | conName (RecGadtC [name] _ _) = name 362 | conName (RecGadtC names _ _) = error $ "conName: internal error; non-singleton GADT record constructor names: " ++ show names 363 | #endif 364 | 365 | -- | Extracts the number of arguments a 'Con' accepts. 366 | conNumArgs :: Con -> Int 367 | conNumArgs (NormalC _ bts) = length bts 368 | conNumArgs (RecC _ vbts) = length vbts 369 | conNumArgs (InfixC _ _ _) = 2 370 | conNumArgs (ForallC _ _ con) = conNumArgs con 371 | #if MIN_VERSION_template_haskell(2,11,0) 372 | conNumArgs (GadtC _ bts _) = length bts 373 | conNumArgs (RecGadtC _ vbts _) = length vbts 374 | #endif 375 | 376 | -- | Given a potentially applied type, like @T a b@, returns the base, unapplied 377 | -- type name, like @T@. 378 | unappliedType :: Type -> Type 379 | unappliedType t@ConT{} = t 380 | unappliedType (AppT t _) = unappliedType t 381 | unappliedType other = error $ "unappliedType: internal error; expected plain applied type, given " ++ show other 382 | 383 | -- | Like 'unappliedType', but extracts the 'Name' instead of 'Type'. 384 | unappliedTypeName :: Type -> Name 385 | unappliedTypeName t = let (ConT name) = unappliedType t in name 386 | 387 | -- | The counterpart to 'unappliedType', this gets the arguments a type is 388 | -- applied to. 389 | typeArgs :: Type -> [Type] 390 | typeArgs (AppT t a) = typeArgs t ++ [a] 391 | typeArgs _ = [] 392 | 393 | -- | Given a function type, splits it into its components: quantified type 394 | -- variables, constraint context, argument types, and result type. For 395 | -- example, applying 'splitFnType' to 396 | -- @forall a b c. (Foo a, Foo b, Bar c) => a -> b -> c@ produces 397 | -- @([a, b, c], (Foo a, Foo b, Bar c), [a, b], c)@. 398 | splitFnType :: Type -> ([TyVarBndr], Cxt, [Type], Type) 399 | splitFnType (a `AppT` b `AppT` c) | a == ArrowT = 400 | let (tyVars, ctx, args, result) = splitFnType c 401 | in (tyVars, ctx, b:args, result) 402 | splitFnType (ForallT tyVars ctx a) = 403 | let (tyVars', ctx', args, result) = splitFnType a 404 | in (tyVars ++ tyVars', ctx ++ ctx', args, result) 405 | splitFnType a = ([], [], [], a) 406 | 407 | fnTypeArity :: Type -> Int 408 | fnTypeArity t = let (_, _, args, _) = splitFnType t in length args 409 | 410 | -- | Substitutes a type variable with a type within a particular type. This is 411 | -- used by 'replaceClassConstraint' to swap out the constrained and quantified 412 | -- type variable with the type variable bound within the record declaration. 413 | substituteTypeVar :: Name -> Type -> Type -> Type 414 | substituteTypeVar initial replacement = doReplace 415 | where doReplace (ForallT a b t) = ForallT a b (doReplace t) 416 | doReplace (AppT a b) = AppT (doReplace a) (doReplace b) 417 | doReplace (SigT t k) = SigT (doReplace t) k 418 | doReplace t@(VarT n) 419 | | n == initial = replacement 420 | | otherwise = t 421 | doReplace other = other 422 | 423 | -- | Given a type, returns a list of all of the unique type variables contained 424 | -- within it. 425 | typeVarNames :: Type -> [Name] 426 | typeVarNames (VarT n) = [n] 427 | typeVarNames (AppT a b) = nub (typeVarNames a ++ typeVarNames b) 428 | typeVarNames _ = [] 429 | 430 | -- | Given any arbitrary 'TyVarBndr', gets its 'Name'. 431 | tyVarBndrName :: TyVarBndr -> Name 432 | tyVarBndrName (PlainTV name) = name 433 | tyVarBndrName (KindedTV name _) = name 434 | 435 | -- | Given some 'Info' about a class, get its methods as 'SigD' declarations. 436 | classMethods :: Info -> Q [Dec] 437 | classMethods (ClassI (ClassD _ _ _ _ methods) _) = return $ removeDefaultSigs methods 438 | where removeDefaultSigs = filter $ \case 439 | DefaultSigD{} -> False 440 | _ -> True 441 | classMethods other = fail $ "classMethods: internal error; expected a class type, given " ++ show other 442 | 443 | {------------------------------------------------------------------------------| 444 | | The following definitions abstract over differences in base and | 445 | | template-haskell between GHC versions. This allows the same code to work | 446 | | without writing CPP everywhere and ending up with a small mess. | 447 | |------------------------------------------------------------------------------} 448 | 449 | pattern DataD' :: Cxt -> Name -> [TyVarBndr] -> [Con] -> Dec 450 | #if MIN_VERSION_template_haskell(2,11,0) 451 | pattern DataD' a b c d = DataD a b c Nothing d [] 452 | #else 453 | pattern DataD' a b c d = DataD a b c d [] 454 | #endif 455 | 456 | instanceD' :: Cxt -> Type -> [Dec] -> Dec 457 | #if MIN_VERSION_template_haskell(2,11,0) 458 | instanceD' = InstanceD Nothing 459 | #else 460 | instanceD' = InstanceD 461 | #endif 462 | 463 | standaloneDeriveD' :: Cxt -> Type -> Dec 464 | #if MIN_VERSION_template_haskell(2,12,0) 465 | standaloneDeriveD' = StandaloneDerivD Nothing 466 | #else 467 | standaloneDeriveD' = StandaloneDerivD 468 | #endif 469 | 470 | #if MIN_VERSION_template_haskell(2,11,0) 471 | noStrictness :: Bang 472 | noStrictness = Bang NoSourceUnpackedness NoSourceStrictness 473 | #else 474 | noStrictness :: Strict 475 | noStrictness = NotStrict 476 | #endif 477 | 478 | gadtC' :: Name -> [Type] -> [Type] -> Type -> Con 479 | #if MIN_VERSION_template_haskell(2,11,0) 480 | gadtC' nm _ args result = GadtC [nm] (map (noStrictness,) args) result 481 | #else 482 | gadtC' nm vars args result = ForallC [] equalities (NormalC nm (map (noStrictness,) args)) 483 | where 484 | equalities = reverse $ zipWith equalsT (reverse vars) (reverse $ typeArgs result) 485 | equalsT x y = EqualityT `AppT` x `AppT` y 486 | #endif 487 | -------------------------------------------------------------------------------- /library/Control/Monad/Mock/TH/Internal/TypesQuasi.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide, not-home #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | module Control.Monad.Mock.TH.Internal.TypesQuasi (ts) where 6 | 7 | import Control.Monad ((<=<)) 8 | import Language.Haskell.Exts.Lexer 9 | import Language.Haskell.Exts.Parser 10 | import Language.Haskell.Exts.SrcLoc 11 | import Language.Haskell.Meta.Syntax.Translate (toType) 12 | import Language.Haskell.TH.Instances () 13 | import Language.Haskell.TH.Syntax hiding (Loc) 14 | import Language.Haskell.TH.Quote 15 | 16 | -- | A quasi-quoter like the built-in @[t| ... |]@ quasi-quoter, but produces 17 | -- a /list/ of types instead of a single type. Each type should be separated by 18 | -- a comma. 19 | -- 20 | -- >>> [ts| Bool, (), String |] 21 | -- [ConT GHC.Types.Bool,ConT GHC.Tuple.(),ConT GHC.Base.String] 22 | -- >>> [ts| Maybe Int, Monad m |] 23 | -- [AppT (ConT GHC.Base.Maybe) (ConT GHC.Types.Int),AppT (ConT GHC.Base.Monad) (VarT m)] 24 | ts :: QuasiQuoter 25 | ts = QuasiQuoter 26 | { quoteExp = \str -> case parseTypesSplitOnCommas str of 27 | ParseOk tys -> lift =<< mapM resolveTypeNames tys 28 | ParseFailed _ msg -> fail msg 29 | , quotePat = error "ts can only be used in an expression context" 30 | , quoteType = error "ts can only be used in an expression context" 31 | , quoteDec = error "ts can only be used in an expression context" 32 | } 33 | 34 | parseTypesSplitOnCommas :: String -> ParseResult [Type] 35 | parseTypesSplitOnCommas = fmap (map toType) . mapM parseType <=< lexSplitOnCommas 36 | 37 | lexSplitOnCommas :: String -> ParseResult [String] 38 | lexSplitOnCommas str = splitOnSrcSpans str <$> lexSplittingCommas str 39 | 40 | splitOnSrcSpans :: String -> [SrcSpan] -> [String] 41 | splitOnSrcSpans str [] = [str] 42 | splitOnSrcSpans str spans@(x:xs) = case x of 43 | SrcSpan { srcSpanStartLine = line, srcSpanStartColumn = col } 44 | | line > 1 -> 45 | let (l, _:ls) = break (== '\n') str 46 | (r:rs) = splitOnSrcSpans ls (map advanceLine spans) 47 | in (l ++ "\n" ++ r) : rs 48 | | col > 1 -> 49 | let (currentLs, nextLs) = span ((== line) . srcSpanStartLine) spans 50 | (c:cs) = str 51 | (r:rs) = splitOnSrcSpans cs (map advanceColumn currentLs ++ nextLs) 52 | in (c : r) : rs 53 | | otherwise -> 54 | let (currentLs, nextLs) = span ((== line) . srcSpanStartLine) xs 55 | (_:cs) = str 56 | in "" : splitOnSrcSpans cs (map advanceColumn currentLs ++ nextLs) 57 | 58 | 59 | advanceLine :: SrcSpan -> SrcSpan 60 | advanceLine s@SrcSpan { srcSpanStartLine = line } = s { srcSpanStartLine = line - 1 } 61 | 62 | advanceColumn :: SrcSpan -> SrcSpan 63 | advanceColumn s@SrcSpan { srcSpanStartColumn = col } = s { srcSpanStartColumn = col - 1 } 64 | 65 | lexSplittingCommas :: String -> ParseResult [SrcSpan] 66 | lexSplittingCommas = fmap splittingCommas . lexTokenStream 67 | 68 | splittingCommas :: [Loc Token] -> [SrcSpan] 69 | splittingCommas = map loc . go 70 | where go [] = [] 71 | go (x@Loc{ unLoc = Comma }:xs) = x : go xs 72 | go (Loc{ unLoc = LeftParen }:xs) = go $ skipUntil RightParen xs 73 | go (Loc{ unLoc = LeftSquare }:xs) = go $ skipUntil RightSquare xs 74 | go (Loc{ unLoc = LeftCurly }:xs) = go $ skipUntil RightCurly xs 75 | go (_:xs) = go xs 76 | 77 | skipUntil _ [] = [] 78 | skipUntil d (Loc{ unLoc = LeftParen }:xs) = skipUntil d $ skipUntil RightParen xs 79 | skipUntil d (Loc{ unLoc = LeftSquare }:xs) = skipUntil d $ skipUntil RightSquare xs 80 | skipUntil d (Loc{ unLoc = LeftCurly }:xs) = skipUntil d $ skipUntil RightCurly xs 81 | skipUntil d (Loc{ unLoc = t }:xs) 82 | | t == d = xs 83 | | otherwise = skipUntil d xs 84 | 85 | resolveTypeNames :: Type -> Q Type 86 | resolveTypeNames (AppT a b) = AppT <$> resolveTypeNames a <*> resolveTypeNames b 87 | resolveTypeNames (ConT nm) = ConT <$> resolveTypeName nm 88 | resolveTypeNames (ForallT tyVars ctx t) = ForallT tyVars <$> mapM resolveTypeNames ctx <*> resolveTypeNames t 89 | resolveTypeNames (SigT t k) = SigT <$> resolveTypeNames t <*> resolveTypeNames k 90 | resolveTypeNames t@ArrowT{} = return t 91 | resolveTypeNames t@ConstraintT = return t 92 | resolveTypeNames t@EqualityT = return t 93 | resolveTypeNames t@ListT = return t 94 | resolveTypeNames t@LitT{} = return t 95 | resolveTypeNames t@PromotedConsT = return t 96 | resolveTypeNames t@PromotedNilT = return t 97 | resolveTypeNames t@PromotedT{} = return t 98 | resolveTypeNames t@PromotedTupleT{} = return t 99 | resolveTypeNames t@StarT = return t 100 | resolveTypeNames t@TupleT{} = return t 101 | resolveTypeNames t@UnboxedTupleT{} = return t 102 | resolveTypeNames t@VarT{} = return t 103 | #if MIN_VERSION_template_haskell(2,11,0) 104 | resolveTypeNames (InfixT a n b) = InfixT <$> resolveTypeNames a <*> resolveTypeName n <*> resolveTypeNames b 105 | resolveTypeNames (UInfixT a n b) = UInfixT <$> resolveTypeNames a <*> resolveTypeName n <*> resolveTypeNames b 106 | resolveTypeNames (ParensT t) = ParensT <$> resolveTypeNames t 107 | resolveTypeNames t@WildCardT = return t 108 | #endif 109 | #if MIN_VERSION_template_haskell(2,12,0) 110 | resolveTypeNames t@UnboxedSumT{} = return t 111 | #endif 112 | 113 | resolveTypeName :: Name -> Q Name 114 | resolveTypeName (Name (OccName str) NameS) = lookupTypeName str >>= \case 115 | Just nm -> return nm 116 | Nothing -> fail $ "unbound type name ‘" ++ str ++ "’" 117 | resolveTypeName nm = return nm 118 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: monad-mock 2 | version: 0.2.0.0 3 | category: Testing 4 | synopsis: A monad transformer for mocking mtl-style typeclasses 5 | description: | 6 | This package provides a monad transformer that helps create “mocks” of 7 | @mtl@-style typeclasses, intended for use in unit tests. A mock can be 8 | executed by providing a sequence of expected monadic calls and their results, 9 | and the mock will verify that the computation conforms to the expectation. 10 | 11 | For more information, see the module documentation for "Control.Monad.Mock". 12 | 13 | copyright: 2017 CJ Affiliate by Conversant 14 | license: ISC 15 | author: Alexis King 16 | maintainer: Alexis King 17 | github: cjdev/monad-mock 18 | 19 | extra-source-files: 20 | - CHANGELOG.md 21 | - LICENSE 22 | - package.yaml 23 | - README.md 24 | - stack.yaml 25 | 26 | ghc-options: -Wall 27 | default-extensions: 28 | - DefaultSignatures 29 | - FlexibleContexts 30 | - FlexibleInstances 31 | - GADTs 32 | - GeneralizedNewtypeDeriving 33 | - LambdaCase 34 | - MultiParamTypeClasses 35 | - ScopedTypeVariables 36 | - StandaloneDeriving 37 | - TupleSections 38 | - TypeFamilies 39 | - TypeOperators 40 | 41 | library: 42 | dependencies: 43 | - base >= 4.8.0.0 && < 5 44 | - constraints >= 0.3.1 45 | - exceptions >= 0.6 46 | - haskell-src-exts 47 | - haskell-src-meta 48 | - th-orphans 49 | - monad-control >= 1.0.0.0 && < 2 50 | - mtl 51 | - template-haskell >= 2.10.0.0 && < 2.13 52 | - transformers-base 53 | when: 54 | - condition: impl(ghc < 8) 55 | dependencies: 56 | - transformers 57 | source-dirs: library 58 | 59 | tests: 60 | monad-stub-test-suite: 61 | dependencies: 62 | - base 63 | - hspec 64 | - monad-mock 65 | - mtl 66 | ghc-options: 67 | - -rtsopts 68 | - -threaded 69 | - -with-rtsopts=-N 70 | main: Main.hs 71 | source-dirs: test-suite 72 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.20 2 | 3 | packages: 4 | - '.' 5 | 6 | extra-deps: [] 7 | 8 | flags: {} 9 | 10 | extra-package-dbs: [] 11 | -------------------------------------------------------------------------------- /test-suite/Control/Monad/MockSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | 5 | module Control.Monad.MockSpec (spec) where 6 | 7 | import Prelude hiding (readFile, writeFile) 8 | 9 | import Control.Exception (evaluate) 10 | import Control.Monad.Except (MonadError, runExcept) 11 | import Data.Function ((&)) 12 | import Test.Hspec 13 | 14 | import Control.Monad.Mock 15 | import Control.Monad.Mock.TH 16 | 17 | class MonadError e m => MonadFileSystem e m | m -> e where 18 | readFile :: FilePath -> m String 19 | writeFile :: FilePath -> String -> m () 20 | makeAction "FileSystemAction" [ts| MonadFileSystem String |] 21 | 22 | copyFileAndReturn :: MonadFileSystem e m => FilePath -> FilePath -> m String 23 | copyFileAndReturn a b = do 24 | x <- readFile a 25 | writeFile b x 26 | return x 27 | 28 | spec :: Spec 29 | spec = describe "MockT" $ do 30 | it "runs computations with mocked method implementations" $ do 31 | let result = copyFileAndReturn "foo.txt" "bar.txt" 32 | & runMockT [ ReadFile "foo.txt" :-> "file contents" 33 | , WriteFile "bar.txt" "file contents" :-> () ] 34 | & runExcept 35 | result `shouldBe` Right "file contents" 36 | 37 | it "raises an exception if calls are not in the right order" $ do 38 | let result = copyFileAndReturn "foo.txt" "bar.txt" 39 | & runMockT [ WriteFile "bar.txt" "file contents" :-> () 40 | , ReadFile "foo.txt" :-> "file contents" ] 41 | & runExcept 42 | exnMessage = 43 | "runMockT: argument mismatch in readFile\n\ 44 | \ given: ReadFile \"foo.txt\"\n\ 45 | \ expected: WriteFile \"bar.txt\" \"file contents\"\n" 46 | evaluate result `shouldThrow` errorCall exnMessage 47 | 48 | it "raises an exception if calls are missing" $ do 49 | let result = copyFileAndReturn "foo.txt" "bar.txt" 50 | & runMockT [ ReadFile "foo.txt" :-> "file contents" 51 | , WriteFile "bar.txt" "file contents" :-> () 52 | , ReadFile "qux.txt" :-> "file contents 2" ] 53 | & runExcept 54 | exnMessage = 55 | "runMockT: expected the following unexecuted actions to be run:\n\ 56 | \ ReadFile \"qux.txt\"\n" 57 | evaluate result `shouldThrow` errorCall exnMessage 58 | 59 | it "raises an exception if there are too many calls" $ do 60 | let result = copyFileAndReturn "foo.txt" "bar.txt" 61 | & runMockT [ ReadFile "foo.txt" :-> "file contents" ] 62 | & runExcept 63 | exnMessage = 64 | "runMockT: expected end of program, called writeFile\n\ 65 | \ given action: WriteFile \"bar.txt\" \"file contents\"\n" 66 | evaluate result `shouldThrow` errorCall exnMessage 67 | -------------------------------------------------------------------------------- /test-suite/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} --------------------------------------------------------------------------------