diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## 0.2.0.0 (September 14th, 2017) + +- `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`. + ## 0.1.1.2 (August 1st, 2017) - Added support for GHC 7.10. diff --git a/library/Control/Monad/Mock/TH.hs b/library/Control/Monad/Mock/TH.hs --- a/library/Control/Monad/Mock/TH.hs +++ b/library/Control/Monad/Mock/TH.hs @@ -146,13 +146,13 @@ when (length classArgs == length classVars) $ fail $ "makeAction: cannot derive instance for fully saturated constraint\n" ++ " in: " ++ show (ppr classType) ++ "\n" - ++ " expected: * -> " ++ constraintStr ++ "\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" + ++ " expected: (* -> *) -> " ++ constraintStr ++ "\n" ++ " given: " ++ show (ppr (mkClassKind $ drop (length classArgs) classVars)) -- | Converts a class’s methods to constructors for an action type. There @@ -206,9 +206,33 @@ mkInstance :: Type -> Type -> [Dec] -> Q Dec mkInstance actionT classT methodSigs = do mVar <- newName "m" - methodImpls <- traverse mkInstanceMethod methodSigs + + -- In order to calculate the constraints on the instance, we need to look + -- at the superclasses of the class we're deriving an instance for. For + -- example, given some class: + -- + -- class (AsSomething e, MonadError e m) => MonadFoo e m | m -> e + -- + -- ...if we are asked to derive an instance for @MonadFoo Something@, then + -- we need to generate an instance with a constraint like the following: + -- + -- instance (AsSomething Something, MonadError Something m) + -- => MonadFoo Something (MockT Action m) + -- + -- To do that, we just need to look at the binders of the class, then + -- use that to build a substitution that can be applied to the superclass + -- constraints. + (ClassI (ClassD classContext _ classBindVars _ _) _) <- reify $ unappliedTypeName classT + let classBinds = map tyVarBndrName classBindVars + instanceBinds = typeArgs classT ++ [VarT mVar] + classBindsToInstanceBinds = zip classBinds instanceBinds + contextSubFns = map (uncurry substituteTypeVar) classBindsToInstanceBinds + instanceContext = foldr map classContext contextSubFns + let instanceHead = classT `AppT` (ConT ''MockT `AppT` actionT `AppT` VarT mVar) - return $ instanceD' [ConT ''Monad `AppT` VarT mVar] instanceHead methodImpls + methodImpls <- traverse mkInstanceMethod methodSigs + + return $ instanceD' instanceContext instanceHead methodImpls mkInstanceMethod :: Dec -> Q Dec mkInstanceMethod (SigD name typ) = do diff --git a/monad-mock.cabal b/monad-mock.cabal --- a/monad-mock.cabal +++ b/monad-mock.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: monad-mock -version: 0.1.1.2 +version: 0.2.0.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 @@ -67,8 +67,9 @@ ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N build-depends: base - , monad-mock , hspec + , monad-mock + , mtl other-modules: Control.Monad.MockSpec default-language: Haskell2010 diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: monad-mock -version: 0.1.1.2 +version: 0.2.0.0 category: Testing synopsis: A monad transformer for mocking mtl-style typeclasses description: | @@ -60,8 +60,9 @@ monad-stub-test-suite: dependencies: - base - - monad-mock - hspec + - monad-mock + - mtl ghc-options: - -rtsopts - -threaded diff --git a/test-suite/Control/Monad/MockSpec.hs b/test-suite/Control/Monad/MockSpec.hs --- a/test-suite/Control/Monad/MockSpec.hs +++ b/test-suite/Control/Monad/MockSpec.hs @@ -1,23 +1,25 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FunctionalDependencies #-} module Control.Monad.MockSpec (spec) where import Prelude hiding (readFile, writeFile) import Control.Exception (evaluate) +import Control.Monad.Except (MonadError, runExcept) import Data.Function ((&)) import Test.Hspec import Control.Monad.Mock import Control.Monad.Mock.TH -class Monad m => MonadFileSystem m where +class MonadError e m => MonadFileSystem e m | m -> e where readFile :: FilePath -> m String writeFile :: FilePath -> String -> m () -makeAction "FileSystemAction" [ts| MonadFileSystem |] +makeAction "FileSystemAction" [ts| MonadFileSystem String |] -copyFileAndReturn :: MonadFileSystem m => FilePath -> FilePath -> m String +copyFileAndReturn :: MonadFileSystem e m => FilePath -> FilePath -> m String copyFileAndReturn a b = do x <- readFile a writeFile b x @@ -27,14 +29,16 @@ spec = describe "MockT" $ do it "runs computations with mocked method implementations" $ do let result = copyFileAndReturn "foo.txt" "bar.txt" - & runMock [ ReadFile "foo.txt" :-> "file contents" - , WriteFile "bar.txt" "file contents" :-> () ] - result `shouldBe` "file contents" + & runMockT [ ReadFile "foo.txt" :-> "file contents" + , WriteFile "bar.txt" "file contents" :-> () ] + & runExcept + result `shouldBe` Right "file contents" it "raises an exception if calls are not in the right order" $ do let result = copyFileAndReturn "foo.txt" "bar.txt" - & runMock [ WriteFile "bar.txt" "file contents" :-> () - , ReadFile "foo.txt" :-> "file contents" ] + & runMockT [ WriteFile "bar.txt" "file contents" :-> () + , ReadFile "foo.txt" :-> "file contents" ] + & runExcept exnMessage = "runMockT: argument mismatch in readFile\n\ \ given: ReadFile \"foo.txt\"\n\ @@ -43,9 +47,10 @@ it "raises an exception if calls are missing" $ do let result = copyFileAndReturn "foo.txt" "bar.txt" - & runMock [ ReadFile "foo.txt" :-> "file contents" - , WriteFile "bar.txt" "file contents" :-> () - , ReadFile "qux.txt" :-> "file contents 2" ] + & runMockT [ ReadFile "foo.txt" :-> "file contents" + , WriteFile "bar.txt" "file contents" :-> () + , ReadFile "qux.txt" :-> "file contents 2" ] + & runExcept exnMessage = "runMockT: expected the following unexecuted actions to be run:\n\ \ ReadFile \"qux.txt\"\n" @@ -53,7 +58,8 @@ it "raises an exception if there are too many calls" $ do let result = copyFileAndReturn "foo.txt" "bar.txt" - & runMock [ ReadFile "foo.txt" :-> "file contents" ] + & runMockT [ ReadFile "foo.txt" :-> "file contents" ] + & runExcept exnMessage = "runMockT: expected end of program, called writeFile\n\ \ given action: WriteFile \"bar.txt\" \"file contents\"\n"