tasty-autocollect 0.1.0.0 → 0.2.0.0
raw patch · 27 files changed
+546/−675 lines, 27 filesdep ~containersdep ~textPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: containers, text
API changes (from Hackage documentation)
- Test.Tasty.AutoCollect.ConvertTest: instance GHC.Classes.Eq Test.Tasty.AutoCollect.ConvertTest.Tester
- Test.Tasty.AutoCollect.ConvertTest: instance GHC.Show.Show Test.Tasty.AutoCollect.ConvertTest.Tester
+ Test.Tasty.AutoCollect.ExternalNames: [name_String] :: ExternalNames -> Name
+ Test.Tasty.AutoCollect.ExternalNames: [name_concat] :: ExternalNames -> Name
- Test.Tasty.AutoCollect.ExternalNames: ExternalNames :: Name -> Name -> ExternalNames
+ Test.Tasty.AutoCollect.ExternalNames: ExternalNames :: Name -> Name -> Name -> Name -> ExternalNames
- Test.Tasty.Ext.Todo: testTreeTodo :: TestName -> a -> TestTree
+ Test.Tasty.Ext.Todo: testTreeTodo :: TestName -> TestTree
Files
- CHANGELOG.md +5/−0
- README.md +41/−81
- src/Test/Tasty/AutoCollect/ConvertTest.hs +135/−130
- src/Test/Tasty/AutoCollect/ExternalNames.hs +4/−0
- src/Test/Tasty/AutoCollect/GHC.hs +19/−0
- src/Test/Tasty/AutoCollect/GHC/Shim_8_10.hs +1/−40
- src/Test/Tasty/AutoCollect/GHC/Shim_9_0.hs +1/−31
- src/Test/Tasty/AutoCollect/GHC/Shim_9_2.hs +1/−36
- src/Test/Tasty/AutoCollect/GHC/Shim_Common.hs +3/−29
- src/Test/Tasty/Ext/Todo.hs +2/−2
- tasty-autocollect.cabal +11/−4
- test/Examples.hs +7/−9
- test/Test/Tasty/AutoCollect/ConfigTest.hs +48/−62
- test/Test/Tasty/AutoCollect/ConvertTestTest.hs +154/−160
- test/Test/Tasty/AutoCollect/GenerateMainTest.hs +20/−39
- test/Test/Tasty/AutoCollect/ModuleTypeTest.hs +6/−8
- test/Test/Tasty/AutoCollect/Utils/TreeMapTest.hs +18/−18
- test/Test/Tasty/Ext/TodoTest.hs +30/−24
- test/golden/fail_todos.golden +6/−0
- test/golden/test_args.golden +4/−0
- test/golden/test_batch_args.golden +1/−1
- test/golden/test_batch_type.golden +3/−1
- test/golden/test_prop_bad_arg.golden +6/−0
- test/golden/test_prop_no_args.golden +4/−0
- test/golden/test_todo_args.golden +4/−0
- test/golden/test_todo_type.golden +6/−0
- test/golden/test_type.golden +6/−0
CHANGELOG.md view
@@ -1,5 +1,10 @@ # Unreleased +# v0.2.0.0++* Fix build for GHC 8.10.2+* Greatly simplify framework by replacing `test_testCase` with just `test = testCase ...`+ # v0.1.0.0 Initial release
README.md view
@@ -10,7 +10,7 @@ * Don't use any weird syntax so that syntax highlighters, linters, and formatters still work * Support test functions with multiple arguments like `tasty-golden`'s API (which `tasty-discover` doesn't easily support) * Avoid universally exporting the whole test module, so that GHC can warn about unused test helpers-* Don't add any of the tasty plugins as dependencies (both as Cabal dependencies and as a result of hardcoded logic)+* Support arbitrary test functions (e.g. user-defined test helpers or third-party tasty libraries) ## Usage @@ -49,27 +49,28 @@ {- AUTOCOLLECT.TEST.export -} ) where - import Data.ByteString.Lazy (ByteString) import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.QuickCheck - test_testCase :: Assertion- test_testCase "Addition" = do- 1 + 1 @?= (2 :: Int)- 2 + 2 @?= (4 :: Int)+ test =+ testCase "Addition" $ do+ 1 + 1 @?= (2 :: Int)+ 2 + 2 @?= (4 :: Int) - test_testProperty :: [Int] -> Property- test_testProperty "reverse . reverse === id" = \xs -> (reverse . reverse) xs === id xs+ test =+ testProperty "reverse . reverse === id" $ \xs ->+ (reverse . reverse) xs === id (xs :: [Int]) - test_goldenVsString :: IO ByteString- test_goldenVsString "Example golden test" "test/golden/example.golden" = pure "example"+ test =+ goldenVsString "Example golden test" "test/golden/example.golden" $+ pure "example" - test_testGroup :: [TestTree]- test_testGroup "manually defining a test group" =- [ testCase "some test" $ return ()- , testCase "some other test" $ return ()- ]+ test =+ testGroup "manually defining a test group"+ [ testCase "some test" $ return ()+ , testCase "some other test" $ return ()+ ] ``` ### How it works@@ -80,39 +81,7 @@ 2. If the file contains `{- AUTOCOLLECT.TEST -}`, register the `tasty-autocollect` GHC plugin to rewrite tests (see below). 3. Otherwise, do nothing -In a test file, the plugin will search for any functions starting with `test_`. It will then rewrite the test from the equivalent of:--```hs-test_TESTER :: TYPE-test_TESTER ARG1 ARG2 ... = BODY-```--to the equivalent of:--```hs-tasty_test_N :: TestTree-tasty_test_N = TESTER ARG1 ARG2 ... (BODY :: TYPE)-```--where `N` is an autoincrementing, unique number. Then it will collect all the tests into a `tasty_tests :: [TestTree]` binding, which is exported at the location of the `{- AUTOCOLLECT.TEST.export -}` comment.--This transformation is mostly transparent, which means you can write your own test helpers and they can be used within this framework seamlessly. This also means that syntax like `where` clauses work pretty much as you expect: the `TESTER` and the `ARG`s can be defined in the `where` clause.--However, because the plugin does need to parse the module first, the arguments will need to be parsable as a function pattern, even though it'll be compiled as an expression. So you can't do something like:--```hs-test_testCase :: Assertion-test_testCase (a ++ b) = ...-```--But you can just rewrite this as:--```hs-test_testCase :: Assertion-test_testCase label = ...- where- label = a ++ b-```+In a test file, the plugin will search for any functions named `test`. It will then rename the function to `tasty_test_N`, where `N` is an autoincrementing, unique number. Then it will collect all the tests into a `tasty_tests :: [TestTree]` binding, which is exported at the location of the `{- AUTOCOLLECT.TEST.export -}` comment. ### Configuration @@ -168,23 +137,6 @@ ### Notes -* Note that the type annotation applies to just the body, so if you're writing a QuickCheck test, you'll have to take in the `Arbitrary` arguments as a lambda to the right of the equals sign (or define the function in the `where` clause):-- ```hs- test_testProperty :: Int -> Property-- -- BAD- test_testProperty "my property" x = x === x-- -- GOOD- test_testProperty "my property" = \x -> x === x-- -- ALSO GOOD- test_testProperty "my property" = prop- where- prop x = x === x- ```- * If you're using a formatter like Ormolu/Fourmolu, use `-- $AUTOCOLLECT.TEST.export$` instead; otherwise, the formatter will move it out of the export list. * This works around the issue by reusing Haddock's named section syntax, but it shouldn't be an issue because you shouldn't be building Haddocks for test modules. If this becomes a problem for you, please open an issue. * Upstream ticket: https://github.com/tweag/ormolu/issues/906@@ -193,22 +145,34 @@ In addition to automatically collecting tests, this library also provides some additional functionality out-of-the-box, to make writing + managing tests a seamless experience. +### Integration with QuickCheck/SmallCheck/etc.++Property test frameworks like QuickCheck or SmallCheck work better when defining the types of arguments instead of using lambdas. So there's a special syntax for defining properties:++```hs+test_prop :: [Int] -> Property+test_prop "reverse . reverse === id" xs = (reverse . reverse) xs === id xs+```++This will be rewritten to the equivalent of:++```hs+test =+ testProperty+ "reverse . reverse === id"+ ( (\xs -> (reverse . reverse) xs === id xs)+ :: [Int] -> Property+ )+```+ ### Marking tests as "TODO" If you're of the Test Driven Development (TDD) mentality, you might want to specify what tests you want to write before actually writing any code. In this workflow, you might not even know what kind of test you want to write (e.g. HUnit, QuickCheck, etc.). With `tasty-autocollect`, you can use `test_todo` to write down tests you'd like to write. By default, they'll pass with a "TODO" message, but you can also pass `--fail-todos` at runtime to make them fail instead. -You can write whatever you want in the body of the test, and it'll be typechecked, but won't be used at runtime.- ```hs-test_todo :: ()-test_todo "a test to implement later" = ()--test_todo :: Assertion-test_todo "a test that'll compile but won't run" = do- x <- myFunction- x @?= ...+test_todo = "a test to implement later" ``` ### Defining batches of tests@@ -216,7 +180,6 @@ With `tasty-autocollect`, you can write a set of tests in one definition without needing to nest them within a test group. For example, ```hs-test_batch :: [TestTree] test_batch = [ testCase ("test #" ++ show x) $ return () | x <- [1, 5, 10 :: Int]@@ -226,14 +189,11 @@ is equivalent to writing: ```hs-test_testCase :: Assertion-test_testCase "test #1" = return ()+test = testCase "test #1" $ return () -test_testCase :: Assertion-test_testCase "test #5" = return ()+test = testCase "test #5" $ return () -test_testCase :: Assertion-test_testCase "test #10" = return ()+test = testCase "test #10" $ return () ``` ## Comparison with `tasty-discover`
src/Test/Tasty/AutoCollect/ConvertTest.hs view
@@ -6,10 +6,10 @@ plugin, ) where +import Control.Monad (unless) import Control.Monad.Trans.State.Strict (State) import qualified Control.Monad.Trans.State.Strict as State import Data.Foldable (toList)-import Data.List (intercalate, stripPrefix) import Data.Sequence (Seq) import qualified Data.Sequence as Seq @@ -41,8 +41,7 @@ bar, ) where -test_<tester> :: <type>-test_<tester> <name> <other args> = <test>+test = ... @ to the equivalent of@@ -50,22 +49,22 @@ @ module MyTest ( foo,- tests,+ tasty_tests, bar, ) where -tests :: [TestTree]-tests = [test1]+tasty_tests :: [TestTree]+tasty_tests = [tasty_test_1] -test1 :: TestTree-test1 = <tester> <name> <other args> (<test> :: <type>)+tasty_test_1 :: TestTree+tasty_test_1 = ... @ -} transformTestModule :: ExternalNames -> HsParsedModule -> HsParsedModule transformTestModule names parsedModl = parsedModl{hpm_module = updateModule <$> hpm_module parsedModl} where updateModule modl =- let (decls, testNames) = runConvertTestM $ mapM (convertTest names) $ hsmodDecls modl+ let (decls, testNames) = runConvertTestM $ concatMapM (convertTest names) $ hsmodDecls modl in modl { hsmodExports = updateExports <$> hsmodExports modl , hsmodDecls = mkTestsList testNames ++ decls@@ -92,157 +91,158 @@ ] flattenTestList testsList =- mkHsApp (lhsvar $ mkLRdrName "concat") $- genLoc . ExprWithTySig noAnn testsList $- HsWC NoExtField . hsTypeToHsSigType . genLoc $- HsListTy noAnn (getListOfTestTreeType names)+ mkHsApp (lhsvar $ genLoc $ getRdrName $ name_concat names) $+ mkExprTypeSig testsList . genLoc $+ HsListTy noAnn (getListOfTestTreeType names) {- | If the given declaration is a test, return the converted test, or otherwise return it unmodified -}-convertTest :: ExternalNames -> LHsDecl GhcPs -> ConvertTestM (LHsDecl GhcPs)-convertTest names loc =- case parseDecl loc of- -- e.g. test_testCase :: Assertion- -- => test1 :: [TestTree]+convertTest :: ExternalNames -> LHsDecl GhcPs -> ConvertTestM [LHsDecl GhcPs]+convertTest names ldecl =+ case parseDecl ldecl of Just (FuncSig [funcName] ty)- | Just testType <- parseTestType funcName -> do+ | Just testType <- parseTestType (fromRdrName funcName) -> do testName <- getNextTestName setLastSeenSig SigInfo { testType , testName- , testHsType = ty+ , signatureType = ty }- pure (genFuncSig testName (getListOfTestTreeType names) <$ loc)- -- e.g. test_testCase "test name" = <body>- -- => test1 = [testCase "test name" (<body> :: Assertion)]+ unless (isValidForTestType names testType ty) $+ autocollectError . unlines $+ [ "Expected type: " ++ typeForTestType testType+ , "Got: " ++ showPpr ty+ ]+ pure [genFuncSig testName (getListOfTestTreeType names) <$ ldecl] Just (FuncDef funcName funcDefs)- | Just testType <- parseTestType funcName -> do- (testName, funcBodyType) <-- getLastSeenSig >>= \case- Nothing -> autocollectError $ "Found test without type signature at " ++ getSpanLine funcName- Just SigInfo{testType = testTypeFromSig, ..}- | testType == testTypeFromSig -> pure (testName, testHsType)- | otherwise -> autocollectError $ "Found test with different type of signature: " ++ show (testType, testTypeFromSig)+ | Just testType <- parseTestType (fromRdrName funcName) -> do+ mSigInfo <- getLastSeenSig+ concatMapM (convertSingleTest funcName testType mSigInfo . unLoc) funcDefs+ -- anything else leave unmodified+ _ -> pure [ldecl]+ where+ convertSingleTest funcName testType mSigInfo FuncSingleDef{..} = do+ (testName, mSigType, needsFuncSig) <-+ case mSigInfo of+ Nothing -> do+ testName <- getNextTestName+ pure (testName, Nothing, True)+ Just SigInfo{testType = testTypeFromSig, ..}+ | testType == testTypeFromSig -> pure (testName, Just signatureType, False)+ | otherwise -> autocollectError $ "Found test with different type of signature: " ++ show (testType, testTypeFromSig) - FuncSingleDef{..} <-- case funcDefs of- [] -> autocollectError $ "Test unexpectedly had no bindings at " ++ getSpanLine funcName- [funcDef] -> pure $ unLoc funcDef- _ ->- autocollectError . unlines $- [ "Found multiple tests named " ++ fromRdrName funcName ++ " at: " ++ intercalate ", " (map getSpanLine funcDefs)- , "Did you forget to add a type annotation for a test?"- ]+ funcBody <-+ case funcDefGuards of+ [FuncGuardedBody [] body] -> pure body+ _ ->+ autocollectError . unlines $+ [ "Test should have no guards."+ , "Found guards at " ++ getSpanLine funcName+ ] - funcBody <-- case funcDefGuards of- [FuncGuardedBody [] body] -> pure body- _ ->- autocollectError . unlines $- [ "Test should have no guards."- , "Found guards at " ++ getSpanLine funcName- ]+ testBody <-+ case testType of+ TestNormal -> do+ checkNoArgs testType funcDefArgs+ pure $ singleExpr funcBody+ TestProp -> do+ (name, remainingPats) <-+ case funcDefArgs of+ [] -> autocollectError "test_prop requires at least the name of the test"+ L _ (LitPat _ (HsString _ s)) : rest -> return (unpackFS s, rest)+ arg : _ ->+ autocollectError . unlines $+ [ "test_prop expected a String for the name of the test."+ , "Got: " ++ showPpr arg+ ]+ let propBody = mkHsLam remainingPats funcBody+ pure . singleExpr $+ mkHsApps+ (lhsvar $ mkLRdrName "testProperty")+ [ genLoc $ HsLit noAnn $ mkHsString name+ , maybe propBody (genLoc . ExprWithTySig noAnn propBody) mSigType+ ]+ TestTodo -> do+ checkNoArgs testType funcDefArgs+ pure . singleExpr $+ mkHsApp+ (lhsvar $ genLoc $ getRdrName $ name_testTreeTodo names)+ (mkExprTypeSig funcBody $ mkHsTyVar (name_String names))+ TestBatch -> do+ checkNoArgs testType funcDefArgs+ pure funcBody - -- tester (...funcArgs) (funcBody :: funcBodyType)- let funcBodyWithType = genLoc $ ExprWithTySig noAnn funcBody funcBodyType- testBody =- case testType of- TestSingle tester ->- genLoc . mkExplicitList $- [ mkHsApps (lhsvar $ genLoc $ fromTester names tester) $- map patternToExpr funcDefArgs ++ [funcBodyWithType]- ]- TestBatch- | not (null funcDefArgs) -> autocollectError "test_batch should not be used with arguments"- | not (isListOfTestTree names funcBodyType) -> autocollectError "test_batch needs to be set to a [TestTree]"- | otherwise -> funcBodyWithType+ pure . concat $+ [ if needsFuncSig+ then [genLoc $ genFuncSig testName (getListOfTestTreeType names)]+ else []+ , [genFuncDecl testName [] testBody (Just funcDefWhereClause) <$ ldecl]+ ] - pure (genFuncDecl testName [] testBody (Just funcDefWhereClause) <$ loc)- -- anything else leave unmodified- _ -> pure loc+ singleExpr = genLoc . mkExplicitList . (: []) -{- |-Convert the given pattern to the expression that it would represent-if it were in an expression context.--}-patternToExpr :: LPat GhcPs -> LHsExpr GhcPs-patternToExpr lpat = go (parsePat lpat)- where- unsupported label = autocollectError $ label ++ " unsupported as test argument at " ++ getSpanLine lpat- go = \case- PatWildCard -> unsupported "wildcard patterns"- PatVar name -> genLoc $ HsVar NoExtField name- PatLazy -> unsupported "lazy patterns"- PatAs -> unsupported "as patterns"- PatParens p -> genLoc $ HsPar noAnn $ go p- PatBang -> unsupported "bang patterns"- PatList ps -> genLoc $ mkExplicitList $ map go ps- PatTuple ps boxity -> genLoc $ mkExplicitTuple (map (Present noAnn . go) ps) boxity- PatSum -> unsupported "anonymous sum patterns"- PatConstructor name details ->- case details of- ConstructorPrefix tys args -> lhsvar name `mkHsAppTypes` tys `mkHsApps` map go args- ConstructorRecord HsRecFields{..} ->- genLoc . RecordCon noAnn name $- HsRecFields- { rec_flds = (fmap . fmap . fmap) go rec_flds- , ..- }- ConstructorInfix l r -> mkHsApps (lhsvar name) $ map go [l, r]- PatView -> unsupported "view patterns"- PatSplice splice -> genLoc $ HsSpliceE noAnn splice- PatLiteral lit -> genLoc $ HsLit noAnn lit- PatOverloadedLit lit -> genLoc $ HsOverLit noAnn (unLoc lit)- PatNPlusK -> unsupported "n+k patterns"- PatTypeSig p ty -> genLoc $ ExprWithTySig noAnn (go p) $ hsTypeToHsSigWcType (genLoc (unLoc ty))+ checkNoArgs testType args =+ unless (null args) $+ autocollectError . unwords $+ [ showTestType testType ++ " should not be used with arguments"+ , "(at " ++ getSpanLine ldecl ++ ")"+ ] -- | Identifier for the generated `tests` list. testListName :: LocatedN RdrName testListName = mkLRdrName testListIdentifier data TestType- = TestSingle Tester+ = TestNormal+ | TestProp+ | TestTodo | TestBatch deriving (Show, Eq) -data Tester- = Tester String- | TesterTodo- deriving (Show, Eq)+parseTestType :: String -> Maybe TestType+parseTestType = \case+ "test" -> Just TestNormal+ "test_prop" -> Just TestProp+ "test_todo" -> Just TestTodo+ "test_batch" -> Just TestBatch+ _ -> Nothing -parseTestType :: LocatedN RdrName -> Maybe TestType-parseTestType = fmap toTestType . stripPrefix "test_" . fromRdrName+showTestType :: TestType -> String+showTestType = \case+ TestNormal -> "test"+ TestProp -> "test_prop"+ TestTodo -> "test_todo"+ TestBatch -> "test_batch"++isValidForTestType :: ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool+isValidForTestType names = \case+ TestNormal -> parsedTypeMatches $ isTypeVarNamed (name_TestTree names)+ TestProp -> const True+ TestTodo -> parsedTypeMatches $ isTypeVarNamed (name_String names)+ TestBatch -> parsedTypeMatches $ \case+ TypeList ty -> isTypeVarNamed (name_TestTree names) ty+ _ -> False where- toTestType = \case- "batch" -> TestBatch- "todo" -> TestSingle TesterTodo- s -> TestSingle (Tester s)+ parsedTypeMatches f = maybe False f . parseSigWcType -fromTester :: ExternalNames -> Tester -> RdrName-fromTester names = \case- Tester name -> mkRdrName name- TesterTodo -> getRdrName $ name_testTreeTodo names+typeForTestType :: TestType -> String+typeForTestType = \case+ TestNormal -> "TestTree"+ TestProp -> "(Testable prop => prop)"+ TestTodo -> "String"+ TestBatch -> "[TestTree]" +isTypeVarNamed :: Name -> ParsedType -> Bool+isTypeVarNamed name = \case+ TypeVar _ (L _ n) -> rdrNameOcc n == rdrNameOcc (getRdrName name)+ _ -> False+ -- | Return the `[TestTree]` type. getListOfTestTreeType :: ExternalNames -> LHsType GhcPs-getListOfTestTreeType names =- (genLoc . HsListTy noAnn)- . (genLoc . HsTyVar noAnn NotPromoted)- $ genLoc testTreeName- where- testTreeName = getRdrName (name_TestTree names)---- | Return True if the given type is `[TestTree]`.-isListOfTestTree :: ExternalNames -> LHsSigWcType GhcPs -> Bool-isListOfTestTree names ty =- case parseSigWcType ty of- Just (TypeList (TypeVar _ (L _ name))) -> rdrNameOcc name == rdrNameOcc testTreeName- _ -> False- where- testTreeName = getRdrName (name_TestTree names)+getListOfTestTreeType names = genLoc $ HsListTy noAnn $ mkHsTyVar (name_TestTree names) {----- Test converter monad -----} @@ -255,11 +255,11 @@ data SigInfo = SigInfo { testType :: TestType- -- ^ The parsed tester+ -- ^ The type of test represented in this signature , testName :: LocatedN RdrName -- ^ The generated name for the test- , testHsType :: LHsSigWcType GhcPs- -- ^ The type of the test body+ , signatureType :: LHsSigWcType GhcPs+ -- ^ The type captured in the signature } runConvertTestM :: ConvertTestM a -> (a, [LocatedN RdrName])@@ -285,3 +285,8 @@ let nextTestName = mkLRdrName $ testIdentifier (length allTests) State.put state{allTests = allTests Seq.|> nextTestName} pure nextTestName++{----- Utilities -----}++concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f = fmap concat . mapM f
src/Test/Tasty/AutoCollect/ExternalNames.hs view
@@ -15,12 +15,16 @@ data ExternalNames = ExternalNames { name_TestTree :: Name , name_testTreeTodo :: Name+ , name_String :: Name+ , name_concat :: Name } loadExternalNames :: HscEnv -> IO ExternalNames loadExternalNames env = do name_TestTree <- loadName ''TestTree name_testTreeTodo <- loadName 'testTreeTodo+ name_String <- loadName ''String+ name_concat <- loadName 'concat pure ExternalNames{..} where loadName name =
src/Test/Tasty/AutoCollect/GHC.hs view
@@ -4,11 +4,16 @@ module Test.Tasty.AutoCollect.GHC ( module Test.Tasty.AutoCollect.GHC.Shim, + -- * Output helpers+ showPpr,+ -- * Builders genFuncSig, genFuncDecl, lhsvar, mkHsAppTypes,+ mkHsTyVar,+ mkExprTypeSig, -- * Located utilities genLoc,@@ -32,6 +37,11 @@ import Test.Tasty.AutoCollect.GHC.Shim +{----- Output helpers -----}++showPpr :: Outputable a => a -> String+showPpr = showSDocUnsafe . ppr+ {----- Builders -----} genFuncSig :: LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs@@ -58,6 +68,15 @@ mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs mkHsAppType e t = genLoc $ HsAppType xAppTypeE e (HsWC noExtField t)++mkHsTyVar :: Name -> LHsType GhcPs+mkHsTyVar = genLoc . HsTyVar noAnn NotPromoted . genLoc . getRdrName++-- | mkExprTypeSig <e> <t> = (<e> :: <t>)+mkExprTypeSig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs+mkExprTypeSig e t =+ genLoc . ExprWithTySig noAnn e $+ HsWC NoExtField (hsTypeToHsSigType t) {----- Located utilities -----}
src/Test/Tasty/AutoCollect/GHC/Shim_8_10.hs view
@@ -31,9 +31,6 @@ parseSigWcType, parseType, - -- ** Pat- parsePat,- -- ** Expr mkExplicitList, mkExplicitTuple,@@ -56,7 +53,7 @@ -- Re-exports import ApiAnnotation as X (AnnotationComment (..)) import GHC.Hs as X hiding (mkHsAppType, mkHsAppTypes, mkMatch)-import GhcPlugins as X hiding (getHscEnv, getLoc, srcSpanStart, unLoc)+import GhcPlugins as X hiding (getHscEnv, getLoc, showPpr, srcSpanStart, unLoc) import HscMain as X (getHscEnv) import NameCache as X (NameCache) @@ -163,42 +160,6 @@ HsTyVar _ flag name -> Just $ TypeVar flag name HsListTy _ t -> TypeList <$> parseType t _ -> Nothing--{----- Compat / Pat -----}--parsePat :: LPat GhcPs -> ParsedPat-parsePat (L _ pat) =- case pat of- WildPat{} -> PatWildCard- VarPat _ name -> PatVar name- LazyPat{} -> PatLazy- AsPat{} -> PatAs- ParPat _ p -> PatParens (parsePat p)- BangPat{} -> PatBang- ListPat _ ps -> PatList (map parsePat ps)- TuplePat _ ps boxity -> PatTuple (map parsePat ps) boxity- SumPat{} -> PatSum- ConPatIn name details ->- PatConstructor name $- case details of- PrefixCon args -> ConstructorPrefix [] $ map parsePat args- RecCon fields -> ConstructorRecord $ parsePat <$> fields- InfixCon l r -> ConstructorInfix (parsePat l) (parsePat r)- ConPatOut{} -> onlyTC "ConPatOut"- ViewPat{} -> PatView- SplicePat _ splice -> PatSplice splice- LitPat _ lit -> PatLiteral lit- NPat _ lit _ _ -> PatOverloadedLit lit- NPlusKPat{} -> PatNPlusK- SigPat _ p (HsWC _ (HsIB _ ty)) -> PatTypeSig (parsePat p) ty- CoPat{} -> onlyTC "CoPat"- -- impossible cases that GHC 8.10 isn't smart enough to prune- SigPat _ _ (HsWC _ (XHsImplicitBndrs x)) -> noExtCon x- SigPat _ _ (XHsWildCardBndrs x) -> noExtCon x- XPat x -> noExtCon x- where- -- https://gitlab.haskell.org/ghc/ghc/-/commit/c42754d5fdd3c2db554d9541bab22d1b3def4be7- onlyTC label = error $ "Unexpectedly got: " ++ label {----- Compat / Expr -----}
src/Test/Tasty/AutoCollect/GHC/Shim_9_0.hs view
@@ -30,9 +30,6 @@ parseSigWcType, parseType, - -- ** Pat- parsePat,- -- ** Expr mkExplicitList, mkExplicitTuple,@@ -53,7 +50,7 @@ import GHC.Driver.Main as X (getHscEnv) import GHC.Hs as X hiding (mkHsAppType, mkHsAppTypes, mkMatch) import GHC.Parser.Annotation as X (AnnotationComment (..))-import GHC.Plugins as X hiding (getHscEnv, srcSpanStart, varName)+import GHC.Plugins as X hiding (getHscEnv, showPpr, srcSpanStart, varName) import GHC.Types.Name.Cache as X (NameCache) import qualified Data.Text as Text@@ -146,33 +143,6 @@ HsTyVar _ flag name -> Just $ TypeVar flag name HsListTy _ t -> TypeList <$> parseType t _ -> Nothing--{----- Compat / Pat -----}--parsePat :: LPat GhcPs -> ParsedPat-parsePat (L _ pat) =- case pat of- WildPat{} -> PatWildCard- VarPat _ name -> PatVar name- LazyPat{} -> PatLazy- AsPat{} -> PatAs- ParPat _ p -> PatParens (parsePat p)- BangPat{} -> PatBang- ListPat _ ps -> PatList (map parsePat ps)- TuplePat _ ps boxity -> PatTuple (map parsePat ps) boxity- SumPat{} -> PatSum- ConPat _ name details ->- PatConstructor name $- case details of- PrefixCon args -> ConstructorPrefix [] $ map parsePat args- RecCon fields -> ConstructorRecord $ parsePat <$> fields- InfixCon l r -> ConstructorInfix (parsePat l) (parsePat r)- ViewPat{} -> PatView- SplicePat _ splice -> PatSplice splice- LitPat _ lit -> PatLiteral lit- NPat _ lit _ _ -> PatOverloadedLit lit- NPlusKPat{} -> PatNPlusK- SigPat _ p (HsPS _ ty) -> PatTypeSig (parsePat p) ty {----- Compat / Expr -----}
src/Test/Tasty/AutoCollect/GHC/Shim_9_2.hs view
@@ -31,9 +31,6 @@ parseSigWcType, parseType, - -- ** Pat- parsePat,- -- ** Expr mkExplicitList, mkExplicitTuple,@@ -43,7 +40,7 @@ -- Re-exports import GHC.Driver.Main as X (getHscEnv) import GHC.Hs as X hiding (comment, mkHsAppType, mkHsAppTypes)-import GHC.Plugins as X hiding (AnnBind (..), AnnExpr' (..), getHscEnv, srcSpanStart, varName)+import GHC.Plugins as X hiding (AnnBind (..), AnnExpr' (..), getHscEnv, showPpr, srcSpanStart, varName) import GHC.Types.Name.Cache as X (NameCache) import qualified Data.Text as Text@@ -135,38 +132,6 @@ HsTyVar _ flag name -> Just $ TypeVar flag name HsListTy _ t -> TypeList <$> parseType t _ -> Nothing--{----- Compat / Pat -----}--parsePat :: LPat GhcPs -> ParsedPat-parsePat (L _ pat) =- case pat of- WildPat{} -> PatWildCard- VarPat _ name -> PatVar name- LazyPat{} -> PatLazy- AsPat{} -> PatAs- ParPat _ p -> PatParens (parsePat p)- BangPat{} -> PatBang- ListPat _ ps -> PatList (map parsePat ps)- TuplePat _ ps boxity -> PatTuple (map parsePat ps) boxity- SumPat{} -> PatSum- ConPat _ name details ->- PatConstructor name $- case details of- PrefixCon tyargs args -> ConstructorPrefix (map hsps_body tyargs) (map parsePat args)- RecCon HsRecFields{..} ->- ConstructorRecord- HsRecFields- { rec_flds = (fmap . fmap . fmap) parsePat rec_flds- , ..- }- InfixCon l r -> ConstructorInfix (parsePat l) (parsePat r)- ViewPat{} -> PatView- SplicePat _ splice -> PatSplice splice- LitPat _ lit -> PatLiteral lit- NPat _ lit _ _ -> PatOverloadedLit lit- NPlusKPat{} -> PatNPlusK- SigPat _ p (HsPS _ ty) -> PatTypeSig (parsePat p) ty {----- Compat / Expr -----}
src/Test/Tasty/AutoCollect/GHC/Shim_Common.hs view
@@ -5,23 +5,20 @@ FuncSingleDef (..), FuncGuardedBody (..), ParsedType (..),- ParsedPat (..),- ConstructorDetails (..), ) where import GHC.Hs #if __GLASGOW_HASKELL__ == 810-import BasicTypes (Boxity, PromotionFlag)+import BasicTypes (PromotionFlag) import RdrName (RdrName) import SrcLoc (Located) #elif __GLASGOW_HASKELL__ == 900-import GHC.Types.Basic (Boxity, PromotionFlag)+import GHC.Types.Basic (PromotionFlag) import GHC.Types.Name.Reader (RdrName) import GHC.Types.SrcLoc (Located) #elif __GLASGOW_HASKELL__ == 902-import GHC.Types.Basic (Boxity, PromotionFlag)+import GHC.Types.Basic (PromotionFlag) import GHC.Types.Name.Reader (RdrName)-import GHC.Types.SrcLoc (Located) #endif #if __GLASGOW_HASKELL__ < 902@@ -47,26 +44,3 @@ data ParsedType = TypeVar PromotionFlag (LocatedN RdrName) | TypeList ParsedType--data ParsedPat- = PatWildCard- | PatVar (LocatedN RdrName)- | PatLazy- | PatAs- | PatParens ParsedPat- | PatBang- | PatList [ParsedPat]- | PatTuple [ParsedPat] Boxity- | PatSum- | PatConstructor (LocatedN RdrName) ConstructorDetails- | PatView- | PatSplice (HsSplice GhcPs)- | PatLiteral (HsLit GhcPs)- | PatOverloadedLit (Located (HsOverLit GhcPs))- | PatNPlusK- | PatTypeSig ParsedPat (LHsType GhcPs)--data ConstructorDetails- = ConstructorPrefix [LHsType GhcPs] [ParsedPat]- | ConstructorRecord (HsRecFields GhcPs ParsedPat)- | ConstructorInfix ParsedPat ParsedPat
src/Test/Tasty/Ext/Todo.hs view
@@ -46,5 +46,5 @@ optionCLParser = flagCLParser Nothing (FailTodos True) -- | A TestTree representing a test that will be written at some point.-testTreeTodo :: TestName -> a -> TestTree-testTreeTodo name _ = SingleTest name TodoTest+testTreeTodo :: TestName -> TestTree+testTreeTodo name = SingleTest name TodoTest
tasty-autocollect.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: tasty-autocollect-version: 0.1.0.0+version: 0.2.0.0 synopsis: Autocollection of tasty tests. description: Autocollection of tasty tests. See README.md for more details. category: Testing@@ -20,11 +20,18 @@ README.md CHANGELOG.md test/golden/example.golden+ test/golden/fail_todos.golden test/golden/output_group_type_flat.golden test/golden/output_group_type_modules.golden test/golden/output_group_type_tree.golden+ test/golden/test_args.golden test/golden/test_batch_args.golden test/golden/test_batch_type.golden+ test/golden/test_prop_bad_arg.golden+ test/golden/test_prop_no_args.golden+ test/golden/test_todo_args.golden+ test/golden/test_todo_type.golden+ test/golden/test_type.golden source-repository head type: git@@ -52,13 +59,13 @@ ghc-options: -Wall build-depends: base >=4.14 && <5- , containers >=0.6.4.1 && <0.7+ , containers >=0.6.2.1 && <0.7 , directory >=1.3.6.0 && <2 , filepath >=1.4.2.1 && <2 , ghc >=8.10 && <9.3 , tasty >=1.4.2.1 && <2 , template-haskell >=2.16 && <2.19- , text >=1.2.4.1 && <3+ , text >=1.2.3.2 && <3 , transformers >=0.5.6.2 && <1 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances@@ -85,7 +92,7 @@ build-depends: base >=4.14 && <5 , tasty-autocollect- , text >=1.2.4.1 && <3+ , text >=1.2.3.2 && <3 if impl(ghc >= 8.0) ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances if impl(ghc < 8.8)
test/Examples.hs view
@@ -5,21 +5,19 @@ -- $AUTOCOLLECT.TEST.export$ ) where -import Data.ByteString.Lazy (ByteString) import Test.Tasty.Golden import Test.Tasty.HUnit import Test.Tasty.QuickCheck -test_testCase :: Assertion-test_testCase "Addition" = do+test = testCase "Addition" $ do 1 + 1 @?= (2 :: Int) 2 + 2 @?= (4 :: Int) -test_testCase :: Assertion-test_testCase "Reverse" = reverse [1, 2, 3] @?= ([3, 2, 1] :: [Int])+test = testCase "Reverse" $ reverse [1, 2, 3] @?= ([3, 2, 1] :: [Int]) -test_testProperty :: [Int] -> Property-test_testProperty "reverse . reverse === id" = \xs -> (reverse . reverse) xs === id xs+test = testProperty "reverse . reverse === id" $ \xs -> (reverse . reverse) xs === id (xs :: [Int]) -test_goldenVsString :: IO ByteString-test_goldenVsString "Example golden test" "test/golden/example.golden" = pure "example"+test_prop :: [Int] -> Property+test_prop "reverse . reverse === id" xs = (reverse . reverse) xs === id xs++test = goldenVsString "Example golden test" "test/golden/example.golden" $ pure "example"
test/Test/Tasty/AutoCollect/ConfigTest.hs view
@@ -24,16 +24,15 @@ {----- Configuration syntax -----} -test_testCase :: Assertion-test_testCase "parseConfig ignores comments" =- parseConfig "# this is a comment" @?~ right anything+test =+ testCase "parseConfig ignores comments" $+ parseConfig "# this is a comment" @?~ right anything -test_testCase :: Assertion-test_testCase "parseConfig ignores empty lines" =- parseConfig "\n\n\n" @?~ right anything+test =+ testCase "parseConfig ignores empty lines" $+ parseConfig "\n\n\n" @?~ right anything -test_testProperty :: Property-test_testProperty "parseConfig errors on ill-formed lines" =+test_prop "parseConfig errors on ill-formed lines" = forAll (invalidLine `suchThat` (not . isIgnored)) $ \line -> parseConfig line `satisfies` left (startsWith "Invalid configuration line:") where@@ -57,38 +56,31 @@ Text.intercalate "=" <$> vectorOf (2 + n) linePart ] -test_testProperty ::- ConfigPiece ->- Spaces ->- Spaces ->- Property-test_testProperty "parseConfig strips whitespace" =- \(ConfigPiece v) kspaces vspaces ->- let k' = wrapSpaces kspaces k- v' = wrapSpaces vspaces v- in parseConfig (k' <> "=" <> v') === parseConfig (k <> "=" <> v)+test_prop :: ConfigPiece -> Spaces -> Spaces -> Property+test_prop "parseConfig strips whitespace" (ConfigPiece v) kspaces vspaces =+ let k' = wrapSpaces kspaces k+ v' = wrapSpaces vspaces v+ in parseConfig (k' <> "=" <> v') === parseConfig (k <> "=" <> v) where k = "suite_name" {----- Configuration options -----} -test_testProperty :: ConfigPiece -> Property-test_testProperty "parseConfig parses suite_name" =- \(ConfigPiece v) ->- parseConfig ("suite_name = " <> v)- `satisfies` right (cfgSuiteName `with` just (eq v))+test_prop :: ConfigPiece -> Property+test_prop "parseConfig parses suite_name" (ConfigPiece v) =+ parseConfig ("suite_name = " <> v)+ `satisfies` right (cfgSuiteName `with` just (eq v)) -test_testProperty :: Property-test_testProperty "parseConfig parses group_type" =+test_prop :: Property+test_prop "parseConfig parses group_type" = forAll (elements groupTypeOptions) $ \(groupTypeName, groupType) -> parseConfig ("group_type = " <> groupTypeName) `satisfies` right (cfgGroupType `with` eq groupType) -test_testProperty :: ConfigPiece -> Property-test_testProperty "parseConfig errors on invalid group_type" =- \(ConfigPiece v) ->- v `notElem` map fst groupTypeOptions ==>- parseConfig ("group_type = " <> v) `satisfies` left (startsWith "Invalid group_type:")+test_prop :: ConfigPiece -> Property+test_prop "parseConfig errors on invalid group_type" (ConfigPiece v) =+ v `notElem` map fst groupTypeOptions ==>+ parseConfig ("group_type = " <> v) `satisfies` left (startsWith "Invalid group_type:") groupTypeOptions :: [(Text, AutoCollectGroupType)] groupTypeOptions =@@ -97,43 +89,37 @@ , ("tree", AutoCollectGroupTree) ] -test_testProperty :: ConfigPiece -> Property-test_testProperty "parseConfig parses strip_suffix" =- \(ConfigPiece v) ->- parseConfig ("strip_suffix = " <> v)- `satisfies` right (cfgStripSuffix `with` eq v)+test_prop :: ConfigPiece -> Property+test_prop "parseConfig parses strip_suffix" (ConfigPiece v) =+ parseConfig ("strip_suffix = " <> v)+ `satisfies` right (cfgStripSuffix `with` eq v) -test_testProperty :: NonEmptyList HsIdentifier -> Property-test_testProperty "parseConfig parses ingredients" =- \(NonEmpty (map getHsIdentifier -> ingredients)) ->- parseConfig ("ingredients = " <> Text.intercalate "," ingredients)- `satisfies` right (cfgIngredients `with` eq ingredients)+test_prop :: NonEmptyList HsIdentifier -> Property+test_prop "parseConfig parses ingredients" (NonEmpty (map getHsIdentifier -> ingredients)) =+ parseConfig ("ingredients = " <> Text.intercalate "," ingredients)+ `satisfies` right (cfgIngredients `with` eq ingredients) -test_testProperty :: NonEmptyList (HsIdentifier, Spaces) -> Property-test_testProperty "parseConfig strips whitespace when parsing ingredients" =- \(NonEmpty (map (first getHsIdentifier) -> identifiers)) ->- let ingredientsVal = Text.intercalate "," . map (\(s, spaces) -> wrapSpaces spaces s) $ identifiers- ingredients = map fst identifiers- in parseConfig ("ingredients = " <> ingredientsVal)- `satisfies` right (cfgIngredients `with` eq ingredients)+test_prop :: NonEmptyList (HsIdentifier, Spaces) -> Property+test_prop "parseConfig strips whitespace when parsing ingredients" (NonEmpty (map (first getHsIdentifier) -> identifiers)) =+ let ingredientsVal = Text.intercalate "," . map (\(s, spaces) -> wrapSpaces spaces s) $ identifiers+ ingredients = map fst identifiers+ in parseConfig ("ingredients = " <> ingredientsVal)+ `satisfies` right (cfgIngredients `with` eq ingredients) -test_testProperty :: BoolOption -> Property-test_testProperty "parseConfig parses ingredients_override (case insensitive)" =- \option ->- parseConfig ("ingredients_override = " <> getText option)- `satisfies` right (cfgIngredientsOverride `with` eq (getBool option))+test_prop :: BoolOption -> Property+test_prop "parseConfig parses ingredients_override (case insensitive)" option =+ parseConfig ("ingredients_override = " <> getText option)+ `satisfies` right (cfgIngredientsOverride `with` eq (getBool option)) -test_testProperty :: ConfigPiece -> Property-test_testProperty "parseConfig errors on invalid ingredients_override" =- \(ConfigPiece v) ->- Text.toLower v `notElem` ["true", "false"] ==>- parseConfig ("ingredients_override = " <> v) `satisfies` left (startsWith "Invalid bool:")+test_prop :: ConfigPiece -> Property+test_prop "parseConfig errors on invalid ingredients_override" (ConfigPiece v) =+ Text.toLower v `notElem` ["true", "false"] ==>+ parseConfig ("ingredients_override = " <> v) `satisfies` left (startsWith "Invalid bool:") -test_testProperty :: ConfigPiece -> ConfigPiece -> Property-test_testProperty "parseConfig errors on unknown keys" =- \(ConfigPiece k) (ConfigPiece v) ->- (k `notElem` validKeys) && not ("#" `Text.isPrefixOf` k) ==>- parseConfig (k <> " = " <> v) `satisfies` left (startsWith "Invalid configuration key:")+test_prop :: ConfigPiece -> ConfigPiece -> Property+test_prop "parseConfig errors on unknown keys" (ConfigPiece k) (ConfigPiece v) =+ (k `notElem` validKeys) && not ("#" `Text.isPrefixOf` k) ==>+ parseConfig (k <> " = " <> v) `satisfies` left (startsWith "Invalid configuration key:") where validKeys = [ "suite_name"
test/Test/Tasty/AutoCollect/ConvertTestTest.hs view
@@ -1,25 +1,17 @@ {- AUTOCOLLECT.TEST -}-{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -#if __GLASGOW_HASKELL__ >= 902-#define __TEST_CONSTRUCTOR_WITH_TYPE_ARGS__ True-#else-#define __TEST_CONSTRUCTOR_WITH_TYPE_ARGS__ False-#endif- module Test.Tasty.AutoCollect.ConvertTestTest ( -- $AUTOCOLLECT.TEST.export$ ) where import Control.Monad (forM_)-import Data.Maybe (catMaybes, maybeToList)+import Data.Maybe (maybeToList) import Data.Text (Text) import qualified Data.Text as Text import Test.Predicates import Test.Predicates.HUnit-import Test.Tasty import Test.Tasty.HUnit import Text.Printf (printf) @@ -27,17 +19,18 @@ import TestUtils.Integration import TestUtils.Predicates -test_testCase :: Assertion-test_testCase "plugin works without tasty installed" =- assertSuccess_ $- runTestWith- ( \proj ->- modifyFile "Test.hs" (filter (not . isTastyImport)) $- proj{dependencies = filter (/= "tasty") (dependencies proj)}- )- [ "test_testCase :: Assertion"- , "test_testCase \"test\" = 1 @?= 1"- ]+{----- General plugin tests -----}++test =+ testCase "plugin works without tasty installed" $+ assertSuccess_ $+ runTestWith+ ( \proj ->+ modifyFile "Test.hs" (filter (not . isTastyImport)) $+ proj{dependencies = filter (/= "tasty") (dependencies proj)}+ )+ [ "test = testCase \"test\" $ 1 @?= 1"+ ] where isTastyImport line = case Text.unpack <$> Text.stripPrefix "import Test.Tasty" line of@@ -50,14 +43,27 @@ -- import from `Test.Tasty.Foo` or `Test.TastyFoo`, which is ok _ -> False -test_batch :: [TestTree]+test =+ testCase "plugin works without Prelude" $+ assertSuccess_ $+ runTestWith+ (modifyFile "Test.hs" (const testFile))+ []+ where+ testFile =+ [ "{- AUTOCOLLECT.TEST -}"+ , "module Test where"+ , "import Prelude ()"+ , "import Test.Tasty.HUnit"+ , "test = testCase \"a test\" (1 @?= 1)"+ ]+ test_batch = [ testCase ("plugin works when " ++ mkLabel ext) $ assertSuccess_ $ runTestWith (\proj -> proj{extraGhcArgs = maybeToList ext <> extraGhcArgs proj})- [ "test_testCase :: Assertion"- , "test_testCase \"1 = 1\" = 1 @?= 1"+ [ "test = testCase \"1 = 1\" $ 1 @?= 1" ] | ext <- [ Just "-XOverloadedStrings"@@ -70,159 +76,89 @@ Nothing -> "no extensions are enabled" Just ext -> "enabling " <> Text.unpack ext -test_batch :: [TestTree]-test_batch =- [ testCase ("test runs with " <> label <> " as an argument") $- assertSuccess_ . runTest $- [ "test_foo :: Assertion"- , "test_foo " <> arg <> " = return ()"- , ""- , "foo :: a -> Assertion -> TestTree"- , "foo _ = testCase \"test helper\""- , extraCode+{----- Overall test file -----}++test = testCase "tests fail when omitting export comment" $ do+ (_, stderr) <-+ assertAnyFailure . runTestWith (modifyFile "Test.hs" (map removeExports)) $+ [ "test = testCase \"a test\" $ return ()" ]- | (label, arg, extraCode) <-- catMaybes- [ test "literal int" "1" simple- , test "literal float" "1.5" simple- , test "literal empty list" "[]" simple- , test "literal list" "[1,2,3]" simple- , test "literal tuple" "(1, True)" simple- , test "constructor" "(Just True)" simple- , test "infix constructor" "(1 :+ 2)" (withExtra "data Foo = (:+) Int Int")- , test "record constructor" "Foo{a = 1}" (withExtra "data Foo = Foo{a :: Int}")- , test "constructor with type args" "(Just @Int 1)" (onlyWhen __TEST_CONSTRUCTOR_WITH_TYPE_ARGS__)- , test "type signature" "(1 :: Int)" simple- ]- ]+ getTestLines stderr @?~ containsStripped (startsWith "Module ‘Test’ does not export") where- test label arg f = f $ Just (label, arg, "" :: Text)- simple = id- withExtra extraCode = fmap (\(label, arg, _) -> (label, arg, extraCode))- onlyWhen b = if b then id else const Nothing--test_batch :: [TestTree]-test_batch =- [ testCase "plugin propagates constructor type args correctly" $ do- (_, stderr) <-- assertAnyFailure . runTest $- [ "test_foo :: Assertion"- , "test_foo (Just @Int True) \"a test\" = return ()"- , " where foo = const testCase"- ]- stderr @?~ hasSubstr "Couldn't match expected type ‘Int’ with actual type ‘Bool’"- | __TEST_CONSTRUCTOR_WITH_TYPE_ARGS__- ]+ removeExports s+ | "module " `Text.isPrefixOf` s = "module Test () where"+ | otherwise = s -test_testCase :: Assertion-test_testCase "test body can use definitions in where clause" = do+test = testCase "test file can omit an explicit export list" $ do (stdout, _) <-- assertSuccess . runTest $- [ "test_testCase :: Assertion"- , "test_testCase \"a test\" = constant @?= 42"- , " where"- , " constant = 42"+ assertSuccess . runTestWith (modifyFile "Test.hs" (map removeExports)) $+ [ "test = testCase \"a test\" $ return ()" ] getTestLines stdout @?~ containsStripped (eq "a test: OK")+ where+ removeExports s+ | "module " `Text.isPrefixOf` s = "module Test where"+ | otherwise = s -test_testCase :: Assertion-test_testCase "test arguments can be defined in where clause" = do- (stdout, _) <-- assertSuccess . runTest $- [ "test_testCase :: Assertion"- , "test_testCase label = constant @?= 42"- , " where"- , " label = \"constant is \" ++ show constant"+test =+ testCase "test file can contain multi-function signature" $+ assertSuccess_ . runTest $+ [ "test = testCase \"test\" $ timesTen 1 @?= timesFive 2" , ""- , "constant :: Int"- , "constant = 42"+ , "timesTen, timesFive :: Int -> Int"+ , "timesTen = (* 10)"+ , "timesFive = (* 5)" ]- getTestLines stdout @?~ containsStripped (eq "constant is 42: OK") -test_testCase :: Assertion-test_testCase "test can be defined with arbitrary testers" = do- (stdout, _) <-- assertSuccess . runTest $- [ "test_boolTestCase :: Bool"- , "test_boolTestCase \"this is a successful test\" = 10 > 2"- , ""- , "boolTestCase :: TestName -> Bool -> TestTree"- , "boolTestCase name x = testCase name $ assertBool \"assertion failed\" x"- ]- getTestLines stdout @?~ containsStripped (eq "this is a successful test: OK")+{----- Generated tests -----} -test_testCase :: Assertion-test_testCase "test can be defined with arbitrary testers in where clause" = do+test = testCase "generated test keeps where clause" $ do (stdout, _) <- assertSuccess . runTest $- [ "test_boolTestCase :: Bool"- , "test_boolTestCase \"this is a successful test\" = 10 > 2"+ [ "test = testCase \"a test\" $ constant @?= 42" , " where"- , " boolTestCase :: TestName -> Bool -> TestTree"- , " boolTestCase name x = testCase name $ assertBool \"assertion failed\" x"+ , " constant = 42" ]- getTestLines stdout @?~ containsStripped (eq "this is a successful test: OK")+ getTestLines stdout @?~ containsStripped (eq "a test: OK") -test_testCase :: Assertion-test_testCase "testers can have any number of arguments" =- assertSuccess_ $ runTest $ map Text.pack $ concatMap mkTest [1 .. 10]- where- -- test_fooX :: Assertion- -- test_fooX "X args" 1 2 3 ... = return ()- -- where- -- fooX name _ _ _ ... = testCase name- mkTest arity =- [ printf "test_foo%d :: Assertion" arity- , printf "test_foo%d \"%d args\" %s = return ()" arity arity (mkArgs arity)- , printf " where"- , printf " foo%d name %s = testCase name" arity (mkPatterns arity)+test =+ testCase "test may specify type" $+ assertSuccess_ . runTest $+ [ "test :: TestTree"+ , "test = testCase \"a test\" $ return ()" ]- mkArgs arity = concatMap (\x -> show x <> " ") [1 .. arity]- mkPatterns arity = concat $ replicate arity "_ " -test_testCase :: Assertion-test_testCase "tests fail when omitting export comment" = do+test = testGolden "test fails when given arguments" "test_args.golden" $ do (_, stderr) <-- assertAnyFailure . runTestWith (modifyFile "Test.hs" (map removeExports)) $- [ "test_testCase :: Assertion"- , "test_testCase \"a test\" = return ()"+ assertAnyFailure . runTest $+ [ "test \"some name\" = testCase \"test\" $ return ()" ]- getTestLines stderr @?~ containsStripped (startsWith "Module ‘Test’ does not export")- where- removeExports s- | "module " `Text.isPrefixOf` s = "module Test () where"- | otherwise = s+ return stderr -test_testCase :: Assertion-test_testCase "test file can omit an explicit export list" = do+test = testGolden "test fails when specifying wrong type" "test_type.golden" $ do+ (_, stderr) <-+ assertAnyFailure . runTest $+ [ "test :: Int"+ , "test = testCase \"test\" $ return ()"+ ]+ return stderr++test = testCase "tests can omit type signatures" $ do (stdout, _) <-- assertSuccess . runTestWith (modifyFile "Test.hs" (map removeExports)) $- [ "test_testCase :: Assertion"- , "test_testCase \"a test\" = return ()"+ assertSuccess . runTest $+ [ "test = testCase \"test 1\" $ return ()"+ , ""+ , "test = testCase \"test 2\" $ return ()" ]- getTestLines stdout @?~ containsStripped (eq "a test: OK")- where- removeExports s- | "module " `Text.isPrefixOf` s = "module Test where"- | otherwise = s+ getTestLines stdout @?~ containsStripped (eq "test 1: OK")+ getTestLines stdout @?~ containsStripped (eq "test 2: OK") -test_testCase :: Assertion-test_testCase "test file can contain multi-function signature" =- assertSuccess_ . runTest $- [ "test_testCase :: Assertion"- , "test_testCase \"test\" = timesTen 1 @?= timesFive 2"- , ""- , "timesTen, timesFive :: Int -> Int"- , "timesTen = (* 10)"- , "timesFive = (* 5)"- ]+{----- test_batch -----} -test_testCase :: Assertion-test_testCase "test_batch generates multiple tests" = do+test = testCase "test_batch generates multiple tests" $ do (stdout, _) <- assertSuccess . runTest $- [ "test_batch :: [TestTree]"- , "test_batch ="+ [ "test_batch =" , " [ testCase (\"test #\" ++ show x) $ return ()" , " | x <- [1 .. 5]" , " ]"@@ -230,12 +166,10 @@ forM_ [1 .. 5 :: Int] $ \x -> getTestLines stdout @?~ containsStripped (eq . Text.pack $ printf "test #%d: OK" x) -test_testCase :: Assertion-test_testCase "test_batch includes where clause" = do+test = testCase "test_batch includes where clause" $ do (stdout, _) <- assertSuccess . runTest $- [ "test_batch :: [TestTree]"- , "test_batch ="+ [ "test_batch =" , " [ testCase (label x) $ return ()" , " | x <- [1 .. 5]" , " ]"@@ -245,20 +179,80 @@ forM_ [1 .. 5 :: Int] $ \x -> getTestLines stdout @?~ containsStripped (eq . Text.pack $ printf "test #%d: OK" x) -test_testGolden :: IO Text-test_testGolden "test_batch fails when given arguments" "test_batch_args.golden" = do+test =+ testCase "test_batch may specify type" $+ assertSuccess_ . runTest $+ [ "test_batch :: [TestTree]"+ , "test_batch = []"+ ]++test = testGolden "test_batch fails when given arguments" "test_batch_args.golden" $ do (_, stderr) <- assertAnyFailure . runTest $- [ "test_batch :: [TestTree]"- , "test_batch \"some name\" = []"+ [ "test_batch \"some name\" = []" ] return stderr -test_testGolden :: IO Text-test_testGolden "test_batch fails when specifying wrong type" "test_batch_type.golden" = do+test = testGolden "test_batch fails when specifying wrong type" "test_batch_type.golden" $ do (_, stderr) <- assertAnyFailure . runTest $- [ "test_batch :: Int"+ [ "test_batch :: TestTree" , "test_batch = []" ] return stderr++{----- test_prop -----}++test =+ testCase "property tests may be written with test_prop" $ do+ (stdout, _) <-+ assertSuccess . runQCTest $+ [ "test_prop :: Positive Int -> [Int] -> Bool"+ , "test_prop \"take N returns at most N elements\" (Positive n) xs = length (take n xs) <= n"+ ]+ getTestLines stdout @?~ containsStripped (eq "take N returns at most N elements: OK")+ stdout @?~ hasSubstr "passed 100 tests"++test =+ testCase "test_prop may omit type" $+ assertSuccess_ . runQCTest $+ [ "test_prop \"test\" x = (x :: Int) === x"+ ]++test =+ testCase "test_prop uses any 'testProperty' function in scope" $ do+ (stdout, _) <-+ assertSuccess . runTest $+ [ "test_prop :: Int -> Bool"+ , "test_prop \"my property test\" x = x == x"+ , ""+ , "testProperty :: String -> (Int -> Bool) -> TestTree"+ , "testProperty name f = testCase name (f 1 @?= True)"+ ]+ getTestLines stdout @?~ containsStripped (eq "my property test: OK")++test =+ testGolden "test_prop fails when no arguments provided" "test_prop_no_args.golden" $ do+ (_, stderr) <- assertAnyFailure $ runTest ["test_prop = 1 === 1"]+ return stderr++test =+ testGolden "test_prop fails when non-string argument provided" "test_prop_bad_arg.golden" $ do+ (_, stderr) <- assertAnyFailure $ runTest ["test_prop 11 = True"]+ return stderr++test =+ testCase "test_prop works when -XOverloadedStrings is enabled" $+ assertSuccess_ $+ runTestWith+ ( \proj -> addQuickCheck $ proj{extraGhcArgs = "-XOverloadedStrings" : extraGhcArgs proj}+ )+ [ "import Test.Tasty.QuickCheck"+ , "test_prop \"a test\" = True"+ ]++runQCTest :: FileContents -> IO (ExitCode, Text, Text)+runQCTest = runTestWith addQuickCheck . ("import Test.Tasty.QuickCheck" :)++addQuickCheck :: GHCProject -> GHCProject+addQuickCheck proj = proj{dependencies = "tasty-quickcheck" : dependencies proj}
test/Test/Tasty/AutoCollect/GenerateMainTest.hs view
@@ -9,19 +9,18 @@ import qualified Data.Text as Text import Test.Predicates import Test.Predicates.HUnit-import Test.Tasty (TestTree) import Test.Tasty.HUnit import TestUtils.Golden import TestUtils.Integration import TestUtils.Predicates -test_testCase :: Assertion-test_testCase "allows omitting all configuration" =- assertSuccess_ $ runMain ["{- AUTOCOLLECT.MAIN -}"]+test =+ testCase "allows omitting all configuration" $+ assertSuccess_ $+ runMain ["{- AUTOCOLLECT.MAIN -}"] -test_testCase :: Assertion-test_testCase "searches recursively" = do+test = testCase "searches recursively" $ do (stdout, _) <- assertSuccess . runMainWith (addFiles [("A/B/C/X/Y/Z.hs", testFile)]) $ [ "{- AUTOCOLLECT.MAIN"@@ -34,11 +33,9 @@ [ "{- AUTOCOLLECT.TEST -}" , "module A.B.C.X.Y.Z where" , "import Test.Tasty.HUnit"- , "test_testCase :: Assertion"- , "test_testCase \"test\" = return ()"+ , "test = testCase \"test\" $ return ()" ] -test_batch :: [TestTree] test_batch = [ testGolden ("output for group_type = " <> groupType <> " is as expected")@@ -64,16 +61,11 @@ [ "{- AUTOCOLLECT.TEST -}" , "module " <> moduleName <> " where" , "import Test.Tasty.HUnit"- , "test_testCase :: Assertion"- , "test_testCase \"test #1 for " <> ident <> "\" = return ()"- , "test_testCase :: Assertion"- , "test_testCase \"test #2 for " <> ident <> "\" = return ()"+ , "test = testCase \"test #1 for " <> ident <> "\" $ return ()"+ , "test = testCase \"test #2 for " <> ident <> "\" $ return ()" ] --- test_batch "Golden test on stdout of generateMain for each group type" = ()--test_testCase :: Assertion-test_testCase "generateMain orders test modules alphabetically" = do+test = testCase "generateMain orders test modules alphabetically" $ do (stdout, _) <- assertSuccess . runMainWith (setTestFiles testFiles) $ [ "{- AUTOCOLLECT.MAIN"@@ -106,12 +98,10 @@ [ "{- AUTOCOLLECT.TEST -}" , "module " <> moduleName <> " where" , "import Test.Tasty.HUnit"- , "test_testCase :: Assertion"- , "test_testCase \"test\" = return ()"+ , "test = testCase \"test\" $ return ()" ] -test_testCase :: Assertion-test_testCase "allows stripping suffix from test modules" = do+test = testCase "allows stripping suffix from test modules" $ do (stdout, _) <- assertSuccess . runMainWith (setTestFiles testFiles) $ [ "{- AUTOCOLLECT.MAIN"@@ -136,12 +126,10 @@ [ "{- AUTOCOLLECT.TEST -}" , "module " <> moduleName <> " where" , "import Test.Tasty.HUnit"- , "test_testCase :: Assertion"- , "test_testCase \"test\" = return ()"+ , "test = testCase \"test\" $ return ()" ] -test_testCase :: Assertion-test_testCase "suffix is stripped before building module tree" = do+test = testCase "suffix is stripped before building module tree" $ do (stdout, _) <- assertSuccess . runMainWith (setTestFiles testFiles) $ [ "{- AUTOCOLLECT.MAIN"@@ -167,8 +155,7 @@ [ "{- AUTOCOLLECT.TEST -}" , "module A.B.CTest where" , "import Test.Tasty.HUnit"- , "test_testCase :: Assertion"- , "test_testCase \"test1\" = return ()"+ , "test = testCase \"test1\" $ return ()" ] ) ,@@ -177,14 +164,12 @@ [ "{- AUTOCOLLECT.TEST -}" , "module A.B.C.DTest where" , "import Test.Tasty.HUnit"- , "test_testCase :: Assertion"- , "test_testCase \"test2\" = return ()"+ , "test = testCase \"test2\" $ return ()" ] ) ] -test_testCase :: Assertion-test_testCase "allows adding extra ingredients" = do+test = testCase "allows adding extra ingredients" $ do (stdout, _) <- assertSuccess . runMainWith (addFiles [("MyIngredient.hs", ingredientFile)]) $ [ "{- AUTOCOLLECT.MAIN"@@ -201,8 +186,7 @@ , " putStrLn \"Hello!\" >> return True" ] -test_testCase :: Assertion-test_testCase "gives informative error when ingredient lacks module" = do+test = testCase "gives informative error when ingredient lacks module" $ do (_, stderr) <- assertAnyFailure . runMain $ [ "{- AUTOCOLLECT.MAIN"@@ -211,8 +195,7 @@ ] getTestLines stderr @?~ contains (eq "Ingredient needs to be fully qualified: myIngredient") -test_testCase :: Assertion-test_testCase "allows disabling default tasty ingredients" = do+test = testCase "allows disabling default tasty ingredients" $ do (_, stderr) <- assertAnyFailure . runMain $ [ "{- AUTOCOLLECT.MAIN"@@ -221,8 +204,7 @@ ] stderr @?~ startsWith "No ingredients agreed to run." -test_testCase :: Assertion-test_testCase "allows overriding suite name" = do+test = testCase "allows overriding suite name" $ do (stdout, _) <- assertSuccess . runMain $ [ "{- AUTOCOLLECT.MAIN"@@ -265,7 +247,6 @@ , "import Test.Tasty" , "import Test.Tasty.HUnit" , ""- , "test_testCase :: Assertion"- , "test_testCase \"a test in " <> moduleName <> "\" = return ()"+ , "test = testCase \"a test in " <> moduleName <> "\" $ return ()" ] )
test/Test/Tasty/AutoCollect/ModuleTypeTest.hs view
@@ -17,26 +17,24 @@ import Test.Tasty.AutoCollect.ModuleType import TestUtils.QuickCheck -test_testCase :: Assertion-test_testCase "parseModuleType finds first comment" = do+test = testCase "parseModuleType finds first comment" $ do parseModuleType (Text.unlines [test, main]) @?= Just ModuleTest parseModuleType (Text.unlines [main, test]) @?~ just ($(qADT 'ModuleMain) anything) where main = "{- AUTOCOLLECT.MAIN -}" test = "{- AUTOCOLLECT.TEST -}" -test_testProperty :: Property-test_testProperty "parseModuleType parses MAIN case-insensitive" =+test_prop :: Property+test_prop "parseModuleType parses MAIN case-insensitive" = forAll (genMixedCase "{- AUTOCOLLECT.MAIN -}") $ \main -> parseModuleType main `satisfies` just ($(qADT 'ModuleMain) anything) -test_testProperty :: Property-test_testProperty "parseModuleType parses TEST case-insensitive" =+test_prop :: Property+test_prop "parseModuleType parses TEST case-insensitive" = forAll (genMixedCase "{- AUTOCOLLECT.TEST -}") $ \test -> parseModuleType test === Just ModuleTest -test_testCase :: Assertion-test_testCase "parseModuleType parses configuration for main modules" = do+test = testCase "parseModuleType parses configuration for main modules" $ do parseModuleType "{- AUTOCOLLECT.MAIN suite_name = foo -}" @?~ just ($(qADT 'ModuleMain) $ cfgSuiteName `with` eq (Just "foo")) parseModuleType "{- AUTOCOLLECT.MAIN\nsuite_name = foo\n-}"
test/Test/Tasty/AutoCollect/Utils/TreeMapTest.hs view
@@ -9,24 +9,24 @@ import Test.Tasty.AutoCollect.Utils.TreeMap -test_testCase :: Assertion-test_testCase "builds the correct tree" =- fromList (zip [["A", "B", "C"], ["A", "B"], ["A", "C", "D"], ["Z"]] [1 :: Int ..])- @?= TreeMap- { value = Nothing- , children =- Map.fromList- [ child "A" Nothing $- [ child "B" (Just 2) $- [ child "C" (Just 1) []- ]- , child "C" Nothing $- [ child "D" (Just 3) []- ]- ]- , child "Z" (Just 4) []- ]- }+test =+ testCase "builds the correct tree" $+ fromList (zip [["A", "B", "C"], ["A", "B"], ["A", "C", "D"], ["Z"]] [1 :: Int ..])+ @?= TreeMap+ { value = Nothing+ , children =+ Map.fromList+ [ child "A" Nothing $+ [ child "B" (Just 2) $+ [ child "C" (Just 1) []+ ]+ , child "C" Nothing $+ [ child "D" (Just 3) []+ ]+ ]+ , child "Z" (Just 4) []+ ]+ } child :: Ord k => k -> Maybe v -> [(k, TreeMap k v)] -> (k, TreeMap k v) child k v sub = (k, TreeMap v (Map.fromList sub))
test/Test/Tasty/Ext/TodoTest.hs view
@@ -9,35 +9,41 @@ import Test.Predicates.HUnit import Test.Tasty.HUnit +import TestUtils.Golden import TestUtils.Integration import TestUtils.Predicates -test_testCase :: Assertion-test_testCase "TODO tests appear as successful tests" = do- (stdout, _) <-- assertSuccess $- runTest- [ "test_todo :: ()"- , "test_todo \"a skipped test\" = ()"- ]+test = testCase "TODO tests appear as successful tests" $ do+ (stdout, _) <- assertSuccess $ runTest ["test_todo = \"a skipped test\""] getTestLines stdout @?~ containsStripped (eq "a skipped test: TODO") -test_testCase :: Assertion-test_testCase "TODO tests can wrap any type" =- assertSuccess_ $- runTest- [ "test_todo :: Int"- , "test_todo \"todo with int\" = 1"- , "test_todo :: Bool"- , "test_todo \"todo with bool\" = True"+test =+ testCase "test_todo may specify type" $+ assertSuccess_ . runTest $+ [ "test_todo :: String"+ , "test_todo = \"a pending test\"" ] -test_testCase :: Assertion-test_testCase "TODO tests show compilation errors" = do+test = testGolden "test_todo fails when given arguments" "test_todo_args.golden" $ do (_, stderr) <-- assertAnyFailure $- runTest- [ "test_todo :: Assertion"- , "test_todo \"partially implemented todo\" = length [] @?= True"- ]- getTestLines stderr @?~ containsStripped (eq "• Couldn't match expected type ‘Int’ with actual type ‘Bool’")+ assertAnyFailure . runTest $+ [ "test_todo \"some name\" = \"a pending test\""+ ]+ return stderr++test = testGolden "test_todo fails when specifying wrong type" "test_todo_type.golden" $ do+ (_, stderr) <-+ assertAnyFailure . runTest $+ [ "test_todo :: Int"+ , "test_todo = \"a pending test\""+ ]+ return stderr++test =+ testGolden "--fail-todos makes TODO tests fail" "fail_todos.golden" $ do+ (stdout, _) <-+ assertAnyFailure $+ runTestWith+ (\proj -> proj{runArgs = ["--fail-todos"]})+ ["test_todo = \"a pending test\""]+ return $ normalizeTestOutput stdout
+ test/golden/fail_todos.golden view
@@ -0,0 +1,6 @@+Main.hs+ Test+ a pending test: TODO+ Failing because --fail-todos was set++1 out of 1 tests failed
+ test/golden/test_args.golden view
@@ -0,0 +1,4 @@++******************** tasty-autocollect failure ********************+test should not be used with arguments (at line 5)+
test/golden/test_batch_args.golden view
@@ -1,4 +1,4 @@ ******************** tasty-autocollect failure ********************-test_batch should not be used with arguments+test_batch should not be used with arguments (at line 5)
test/golden/test_batch_type.golden view
@@ -1,4 +1,6 @@ ******************** tasty-autocollect failure ********************-test_batch needs to be set to a [TestTree]+Expected type: [TestTree]+Got: TestTree+
+ test/golden/test_prop_bad_arg.golden view
@@ -0,0 +1,6 @@++******************** tasty-autocollect failure ********************+test_prop expected a String for the name of the test.+Got: 11++
+ test/golden/test_prop_no_args.golden view
@@ -0,0 +1,4 @@++******************** tasty-autocollect failure ********************+test_prop requires at least the name of the test+
+ test/golden/test_todo_args.golden view
@@ -0,0 +1,4 @@++******************** tasty-autocollect failure ********************+test_todo should not be used with arguments (at line 5)+
+ test/golden/test_todo_type.golden view
@@ -0,0 +1,6 @@++******************** tasty-autocollect failure ********************+Expected type: String+Got: Int++
+ test/golden/test_type.golden view
@@ -0,0 +1,6 @@++******************** tasty-autocollect failure ********************+Expected type: TestTree+Got: Int++