packages feed

test-fixture 0.4.2.0 → 0.5.0.0

raw patch · 8 files changed

+268/−49 lines, 8 filesdep +haskell-src-extsdep +haskell-src-metadep +th-orphansPVP ok

version bump matches the API change (PVP)

Dependencies added: haskell-src-exts, haskell-src-meta, th-orphans

API changes (from Hackage documentation)

+ Control.Monad.TestFixture.TH: ts :: QuasiQuoter
- Control.Monad.TestFixture.TH: mkFixture :: String -> [Name] -> Q [Dec]
+ Control.Monad.TestFixture.TH: mkFixture :: String -> [Type] -> Q [Dec]

Files

CHANGELOG.md view
@@ -1,3 +1,8 @@+# 0.5.0.0 (November 28, 2016)++  - **Breaking**: `mkFixture` now supports constraints in the same form as a Haskell `deriving` clause, which permits “partially-applied” constraints. A new `ts` quasiquoter is provided for the purpose of writing a comma-separated list of Haskell types; see the documentation for more details ([#25](https://github.com/cjdev/test-fixture/issues/25)).+  - Generating fixtures that do not derive any typeclasses no longer produces an error ([#28](https://github.com/cjdev/test-fixture/issues/28)).+ # 0.4.2.0 (November 14, 2016)    - Attempting to generate a fixture for a multi-parameter typeclass now produces a better error message ([#24](https://github.com/cjdev/test-fixture/issues/24)).
README.md view
@@ -33,7 +33,7 @@ Testing this function might be difficult because of all the different possible combinations of scenarios that must be considered. Creating lots of different monads and instances for each case can be boilerplate-heavy and tedious. Using test-fixture, the boilerplate is unnecessary:  ```haskell-mkFixture "Fixture" [''MonadDB, ''MonadHTTP]+mkFixture "Fixture" [ts| MonadDB, MonadHTTP |]  spec = describe "sendAndFetch" $ do   it "returns a record when the http request and db fetch are successful" $ do
src/Control/Monad/TestFixture/TH.hs view
@@ -41,7 +41,7 @@   one might use 'mkFixture' to create some utilities for stubbing these   typeclasses out: -  > mkFixture "Fixture" [''DB, ''HTTP]+  > mkFixture "Fixture" [ts| DB, HTTP |]    This generates code much like the following: @@ -87,7 +87,9 @@ module Control.Monad.TestFixture.TH   ( mkFixture   , def+  , ts   ) where  import Control.Monad.TestFixture.TH.Internal (mkFixture)+import Control.Monad.TestFixture.TH.Internal.TypesQuasi (ts) import Data.Default (def)
src/Control/Monad/TestFixture/TH/Internal.hs view
@@ -12,11 +12,12 @@ import qualified Control.Monad.Reader as Reader  import Prelude hiding (log)-import Control.Monad (join, replicateM, zipWithM)+import Control.Monad (join, replicateM, when, zipWithM) import Control.Monad.TestFixture (TestFixture, TestFixtureT, unimplemented) import Data.Char (isPunctuation, isSymbol) import Data.Default (Default(..)) import Data.List (foldl', nub, partition)+import GHC.Exts (Constraint) import Language.Haskell.TH import Language.Haskell.TH.Syntax @@ -27,32 +28,43 @@   following splice would create a new record type called @Fixture@ with fields   and instances for typeclasses called @Foo@ and @Bar@: -  > mkFixture "Fixture" [''Foo, ''Bar]+  > mkFixture "Fixture" [ts| Foo, Bar |]++  'mkFixture' supports types in the same format that @deriving@ clauses do when+  used with the @GeneralizedNewtypeDeriving@ GHC extension, so deriving+  multi-parameter typeclasses is possible if they are partially applied. For+  example, the following is valid:++  > class MultiParam a m where+  >   doSomething :: a -> m ()+  >+  > mkFixture "Fixture" [ts| MultiParam String |] -}-mkFixture :: String -> [Name] -> Q [Dec]-mkFixture fixtureNameStr classNames = do+mkFixture :: String -> [Type] -> Q [Dec]+mkFixture fixtureNameStr classTypes = do   let fixtureName = mkName fixtureNameStr+  mapM_ assertDerivableConstraint classTypes -  (fixtureDec, fixtureFields) <- mkFixtureRecord fixtureName classNames+  (fixtureDec, fixtureFields) <- mkFixtureRecord fixtureName classTypes   typeSynonyms <- mkFixtureTypeSynonyms fixtureName   defaultInstanceDec <- mkDefaultInstance fixtureName fixtureFields -  infos <- traverse reify classNames-  instanceDecs <- traverse (flip mkInstance fixtureName) infos+  instanceDecs <- traverse (flip mkInstance fixtureName) classTypes    return ([fixtureDec, defaultInstanceDec] ++ typeSynonyms ++ instanceDecs) -mkFixtureRecord :: Name -> [Name] -> Q (Dec, [VarStrictType])-mkFixtureRecord fixtureName classNames = do-  types <- traverse conT classNames+mkFixtureRecord :: Name -> [Type] -> Q (Dec, [VarStrictType])+mkFixtureRecord fixtureName classTypes = do+  let classNames = map unappliedTypeName classTypes   info <- traverse reify classNames   methods <- traverse classMethods info    mVar <- newName "m"-  fixtureFields <- join <$> zipWithM (methodsToFields mVar) types methods+  fixtureFields <- join <$> zipWithM (methodsToFields mVar) classTypes methods   let fixtureCs = [RecC fixtureName fixtureFields] -  let fixtureDec = mkDataD [] fixtureName [PlainTV mVar] fixtureCs+  let mKind = AppT (AppT ArrowT StarT) StarT+  let fixtureDec = mkDataD [] fixtureName [KindedTV mVar mKind] fixtureCs   return (fixtureDec, fixtureFields)  mkFixtureTypeSynonyms :: Name -> Q [Dec]@@ -107,22 +119,59 @@    return $ mkInstanceD [] (AppT (ConT ''Default) appliedFixtureT) [defDecl] -mkInstance :: Info -> Name -> Q Dec-mkInstance (ClassI (ClassD _ className _ _ methods) _) fixtureName = do+mkInstance :: Type -> Name -> Q Dec+mkInstance classType fixtureName = do   writerVar <- VarT <$> newName "w"   stateVar <- VarT <$> newName "s"   mVar <- VarT <$> newName "m"    let fixtureWithoutVarsT = AppT (ConT ''TestFixtureT) (ConT fixtureName)   let fixtureT = AppT (AppT (AppT fixtureWithoutVarsT writerVar) stateVar) mVar-  let instanceHead = AppT (ConT className) fixtureT+  let instanceHead = AppT classType fixtureT +  classInfo <- reify (unappliedTypeName classType)+  methods <- case classInfo of+    ClassI (ClassD _ _ _ _ methods) _ -> return methods+    _ -> fail $ "mkInstance: expected a class type, given " ++ show classType   funDecls <- traverse mkDictInstanceFunc methods    return $ mkInstanceD [AppT (ConT ''Monad) mVar] instanceHead funDecls-mkInstance other _ = fail $ "mkInstance: expected a class name, given " ++ show other  {-|+  Ensures that a provided constraint is something test-fixture 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 $ "mkFixture: 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 $ "mkFixture: 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 $ "mkFixture: 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 $ "mkFixture: cannot derive instance for multi-parameter typeclass\n"+        ++ "      in: " ++ show (ppr classType) ++ "\n"+        ++ "      expected: * -> " ++ constraintStr ++ "\n"+        ++ "      given: " ++ show (ppr (mkClassKind $ drop (length classArgs) classVars))++{-|   Given some 'Info' about a class, get its methods as 'SigD' declarations. -} classMethods :: MonadFail m => Info -> m [Dec]@@ -190,35 +239,50 @@   quantified type and removes the constraint. -} replaceClassConstraint :: MonadFail m => Type -> Name -> Type -> m Type-replaceClassConstraint constraint freeVar (ForallT vars preds typ) = do-  let (newPreds, [replacedPred]) = partition ((constraint /=) . unappliedType) preds-  -- check that this is a single-parameter typeclass-  replacedVar <- case typeVarNames replacedPred of-    [singleVar] -> return singleVar-    _           -> fail "generating instances of multi-parameter typeclasses is currently unsupported"-  let newVars = filter ((replacedVar /=) . tyVarBndrName) vars-      replacedT = replaceTypeVarName replacedVar freeVar typ-  return $ ForallT newVars newPreds replacedT+replaceClassConstraint classType freeVar (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 ++ [VarT freeVar]++      -- 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 test-fixture package"  {-|-  Performs an alpha-renaming within a particular type. Of course, a pure alpha--  renaming would be pretty useless, but this function can be useful because it-  it unhygienic in the sense that type variables can be replaced with others-  with separate bindings.--  This is used by 'replaceClassConstraint' to swap out the constrained and-  quantified type variable with the type variable bound within the record-  declaration.+  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. -}-replaceTypeVarName :: Name -> Name -> Type -> Type-replaceTypeVarName initial replacement = doReplace+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 (VarT n)-          | n == initial = VarT replacement-          | otherwise    = VarT n+        doReplace t@(VarT n)+          | n == initial = replacement+          | otherwise    = t         doReplace other = other  {-|@@ -275,6 +339,19 @@ unappliedType t@ConT{} = t unappliedType (AppT t _) = unappliedType t unappliedType other = 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 inverse of 'unappliedType', this gets the arguments a type is applied to.+-}+typeArgs :: Type -> [Type]+typeArgs (AppT t a) = typeArgs t ++ [a]+typeArgs _          = []  {-|   Given a type, returns a list of all of the unique type variables contained
+ src/Control/Monad/TestFixture/TH/Internal/TypesQuasi.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS_HADDOCK hide, not-home #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++module Control.Monad.TestFixture.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
test-fixture.cabal view
@@ -1,7 +1,7 @@ name:   test-fixture version:-  0.4.2.0+  0.5.0.0 synopsis:   Test monadic side-effects description:@@ -37,11 +37,15 @@     Control.Monad.TestFixture     Control.Monad.TestFixture.TH     Control.Monad.TestFixture.TH.Internal+    Control.Monad.TestFixture.TH.Internal.TypesQuasi   build-depends:       base >= 4.7 && < 5     , data-default+    , haskell-src-exts+    , haskell-src-meta     , mtl     , template-haskell >= 2.10 && < 2.12+    , th-orphans  source-repository head   type:
test/Test/Control/Monad/TestFixture/THSpec.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}@@ -24,11 +25,8 @@ import Control.Monad.TestFixture.TH.Internal (methodNameToFieldName)  class MultiParam a b where-  -- currently, an error is not raised unless the typeclass has at least one-  -- method, but it really ought to be-  multiParamMethod :: a -> b -> () -mkFixture "Fixture" [''MonadFail, ''Quasi]+mkFixture "Fixture" [ts| MonadFail, Quasi |]  spec :: Spec spec = do@@ -39,8 +37,12 @@             , _qNewName = \s -> return $ Name (OccName s) (NameU 0)             , _qReify = \_ -> return $(toExp <$> reify ''MultiParam)             }-      let result = runExcept $ unTestFixtureT (runQ $ mkFixture "Fixture" [''MultiParam]) fixture-      result `shouldBe` Left "generating instances of multi-parameter typeclasses is currently unsupported"+      let result = runExcept $ unTestFixtureT (runQ $ mkFixture "Fixture" [ts| MultiParam |]) fixture+      result `shouldBe` (Left $+           "mkFixture: cannot derive instance for multi-parameter typeclass\n"+        ++ "      in: Test.Control.Monad.TestFixture.THSpec.MultiParam\n"+        ++ "      expected: * -> GHC.Types.Constraint\n"+        ++ "      given: * -> * -> GHC.Types.Constraint")    describe "methodNameToFieldName" $ do     it "prepends an underscore to ordinary names" $ do
test/Test/Control/Monad/TestFixtureSpec.hs view
@@ -7,7 +7,10 @@ #endif  {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} @@ -49,7 +52,7 @@   (Right response) <- sendRequest $ GET ("/record/" ++ show recordId)   fetchRecord $ Id (responseStatus response) -mkFixture "Fixture" [''DB, ''HTTP, ''Throw]+mkFixture "Fixture" [ts| DB, HTTP, Throw |]  -- At compile time, ensure the fixture type synonyms are generated. fixturePure :: FixturePure@@ -76,9 +79,17 @@ fixtureLogStateT :: Monad m => FixtureLogStateT log state m fixtureLogStateT = def :: Fixture (TestFixtureT Fixture log state m) +-- ensure generation of empty fixtures works+mkFixture "EmptyFixture" []++-- ensure fixtures can be generated for partially applied multi-parameter typeclasses+class MultiParam e m | m -> e where+  firstParam :: m e+mkFixture "MultiParamFixture" [ts| MultiParam Bool |]+ spec :: Spec spec = do-  describe "mkFixture" $+  describe "mkFixture" $ do     it "generates a fixture type that can be used to stub out methods" $ do       let fixture = def             { _fetchRecord = \_ -> return $ Right procureRecord@@ -87,6 +98,10 @@             }       let result = unTestFixture (useDBAndHTTP User) fixture       result `shouldBe` Right User++    it "can handle partially applied multi parameter typeclasses" $ do+      let fixture = def { _firstParam = return True }+      unTestFixture firstParam fixture `shouldBe` True    describe "handle throws" $ do     it "capture a thrown error message" $ let