tasty-autocollect 0.2.0.0 → 0.3.0.0

raw patch · 12 files changed

+351/−64 lines, 12 filesdep +tasty-expected-failurePVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-expected-failure

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +43/−0
• src/Test/Tasty/AutoCollect/ConvertTest.hs +145/−55
• src/Test/Tasty/AutoCollect/ExternalNames.hs +16/−5
• src/Test/Tasty/AutoCollect/GHC.hs +21/−3
• tasty-autocollect.cabal +7/−1
• test/Test/Tasty/AutoCollect/ConvertTestTest.hs +72/−0
• test/golden/test_batch_expectFailBecause_output.golden +15/−0
• test/golden/test_expectFailBecause_output.golden +8/−0
• test/golden/test_expectFail_output.golden +8/−0
• test/golden/test_ignoreTestBecause_output.golden +6/−0
• test/golden/test_ignoreTest_output.golden +5/−0

@@ -1,5 +1,10 @@ # Unreleased +# v0.3.0.0++* Fix bug when omitting signature after specifying a signature for a prior test+* Add support for `_expectFail`, `_expectFailBecause`, `_ignoreTest`, `_ignoreTestBecause` suffixes+ # v0.2.0.0  * Fix build for GHC 8.10.2

@@ -25,6 +25,9 @@         build-tools:           - tasty-autocollect:tasty-autocollect         ...+        dependencies:+          - tasty-autocollect+          - ...     ```     ```cabal     test-suite my-library-tests@@ -32,6 +35,9 @@       build-tool-depends:         tasty-autocollect:tasty-autocollect       ...+      build-depends:+        tasty-autocollect+        ...     ```  1. Write your main file to contain just:@@ -58,6 +64,8 @@         1 + 1 @?= (2 :: Int)         2 + 2 @?= (4 :: Int) +    -- See the "Integration with QuickCheck/SmallCheck/etc." section+    -- for a more seamless integration     test =       testProperty "reverse . reverse === id" $ \xs ->         (reverse . reverse) xs === id (xs :: [Int])@@ -194,6 +202,41 @@ test = testCase "test #5" $ return ()  test = testCase "test #10" $ return ()+```++### Integration with `tasty-expected-failures`++If you need to mark a test as an expected failure or just unconditionally skip a test, you can add an appropriate suffix to your test. For example:++```hs+test_expectFail = testCase "this test should fail" $ ...++test_expectFailBecause "Issue #123" = testCase "this test should fail" $ ...++test_ignoreTest = testCase "this test is skipped" $ ...++test_ignoreTestBecause "Issue #123" = testCase "this test is skipped" $ ...+```++The last example will be converted into the equivalent of:++```hs+tasty_test_4 :: TestTree+tasty_test_4 =+  ignoreTestBecause "Issue #123" $+    testCase "this test is skipped" $ ...+```++It also works in combination with other test types, e.g. with `test_batch` to skip the entire batch of tests:++```hs+test_batch_expectFail =+  [ testCase ("this test should fail: " ++ show x) ...+  | x <- ...+  ]++test_prop_expectFailBecause :: Int -> Property+test_prop_expectFailBecause "Issue #123" "some property" x = x === x ```  ## Comparison with `tasty-discover`

@@ -1,17 +1,23 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}  module Test.Tasty.AutoCollect.ConvertTest (   plugin, ) where -import Control.Monad (unless)+import Control.Arrow ((&&&))+import Control.Monad (unless, zipWithM) import Control.Monad.Trans.State.Strict (State) import qualified Control.Monad.Trans.State.Strict as State import Data.Foldable (toList)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (isNothing) import Data.Sequence (Seq) import qualified Data.Sequence as Seq+import qualified Data.Text as Text  import Test.Tasty.AutoCollect.Constants import Test.Tasty.AutoCollect.Error@@ -91,7 +97,7 @@           ]      flattenTestList testsList =-      mkHsApp (lhsvar $ genLoc $ getRdrName $ name_concat names) $+      mkHsApp (mkHsVar $ name_concat names) $         mkExprTypeSig testsList . genLoc $           HsListTy noAnn (getListOfTestTreeType names) @@ -120,113 +126,155 @@     Just (FuncDef funcName funcDefs)       | Just testType <- parseTestType (fromRdrName funcName) -> do           mSigInfo <- getLastSeenSig-          concatMapM (convertSingleTest funcName testType mSigInfo . unLoc) funcDefs+          concat <$> zipWithM (convertSingleTest funcName testType) (mSigInfo : repeat Nothing) funcDefs     -- anything else leave unmodified     _ -> pure [ldecl]   where-    convertSingleTest funcName testType mSigInfo FuncSingleDef{..} = do-      (testName, mSigType, needsFuncSig) <-+    loc = getLocA ldecl++    convertSingleTest funcName testType mSigInfo (L _ FuncSingleDef{..}) = do+      (testName, mSigType) <-         case mSigInfo of           Nothing -> do             testName <- getNextTestName-            pure (testName, Nothing, True)+            pure (testName, Nothing)           Just SigInfo{testType = testTypeFromSig, ..}-            | testType == testTypeFromSig -> pure (testName, Just signatureType, False)+            | testType == testTypeFromSig -> pure (testName, Just signatureType)             | otherwise -> autocollectError $ "Found test with different type of signature: " ++ show (testType, testTypeFromSig) -      funcBody <-+      testBody <-         case funcDefGuards of-          [FuncGuardedBody [] body] -> pure body+          [FuncGuardedBody [] body] -> convertSingleTestBody testType mSigType funcDefArgs body           _ ->             autocollectError . unlines $               [ "Test should have no guards."-              , "Found guards at " ++ getSpanLine funcName+              , "Found guards at " ++ getSpanLine (getLocA 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-       pure . concat $-        [ if needsFuncSig+        [ if isNothing mSigInfo             then [genLoc $ genFuncSig testName (getListOfTestTreeType names)]             else []         , [genFuncDecl testName [] testBody (Just funcDefWhereClause) <$ ldecl]         ] +    convertSingleTestBody testType mSigType args body =+      case testType of+        TestNormal -> do+          checkNoArgs testType args+          pure $ singleExpr body+        TestProp -> do+          (name, remainingPats) <-+            case args of+              arg : rest | Just s <- parseLitStrPat arg -> return (s, rest)+              [] -> autocollectError "test_prop requires at least the name of the test"+              arg : _ ->+                autocollectError . unlines $+                  [ "test_prop expected a String for the name of the test."+                  , "Got: " ++ showPpr arg+                  ]+          let propBody = mkHsLam remainingPats body+          pure . singleExpr $+            mkHsApps+              (lhsvar $ mkLRdrName "testProperty")+              [ mkHsLitString name+              , maybe propBody (genLoc . ExprWithTySig noAnn propBody) mSigType+              ]+        TestTodo -> do+          checkNoArgs testType args+          pure . singleExpr $+            mkHsApp+              (mkHsVar $ name_testTreeTodo names)+              (mkExprTypeSig body $ mkHsTyVar (name_String names))+        TestBatch -> do+          checkNoArgs testType args+          pure body+        TestModify modifier testType' ->+          withTestModifier names modifier loc args $ \args' ->+            convertSingleTestBody testType' mSigType args' body+     singleExpr = genLoc . mkExplicitList . (: [])      checkNoArgs testType args =       unless (null args) $         autocollectError . unwords $           [ showTestType testType ++ " should not be used with arguments"-          , "(at " ++ getSpanLine ldecl ++ ")"+          , "(at " ++ getSpanLine loc ++ ")"           ]  -- | Identifier for the generated `tests` list. testListName :: LocatedN RdrName testListName = mkLRdrName testListIdentifier +-- | Return the `[TestTree]` type.+getListOfTestTreeType :: ExternalNames -> LHsType GhcPs+getListOfTestTreeType names = genLoc $ HsListTy noAnn $ mkHsTyVar (name_TestTree names)++{----- TestType -----}+ data TestType   = TestNormal   | TestProp   | TestTodo   | TestBatch+  | TestModify TestModifier TestType   deriving (Show, Eq) +data TestModifier+  = ExpectFail+  | ExpectFailBecause+  | IgnoreTest+  | IgnoreTestBecause+  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 = go . Text.splitOn "_" . Text.pack+  where+    go = \case+      ["test"] -> Just TestNormal+      ["test", "prop"] -> Just TestProp+      ["test", "todo"] -> Just TestTodo+      ["test", "batch"] -> Just TestBatch+      (unsnoc -> Just (t, "expectFail")) -> TestModify ExpectFail <$> go t+      (unsnoc -> Just (t, "expectFailBecause")) -> TestModify ExpectFailBecause <$> go t+      (unsnoc -> Just (t, "ignoreTest")) -> TestModify IgnoreTest <$> go t+      (unsnoc -> Just (t, "ignoreTestBecause")) -> TestModify IgnoreTestBecause <$> go t+      _ -> Nothing +    unsnoc = fmap (NonEmpty.init &&& NonEmpty.last) . NonEmpty.nonEmpty+ showTestType :: TestType -> String showTestType = \case   TestNormal -> "test"   TestProp -> "test_prop"   TestTodo -> "test_todo"   TestBatch -> "test_batch"+  TestModify modifier tt -> showTestType tt ++ showModifier modifier+  where+    showModifier = \case+      ExpectFail -> "_expectFail"+      ExpectFailBecause -> "_expectFailBecause"+      IgnoreTest -> "_ignoreTest"+      IgnoreTestBecause -> "_ignoreTestBecause"  isValidForTestType :: ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool isValidForTestType names = \case-  TestNormal -> parsedTypeMatches $ isTypeVarNamed (name_TestTree names)+  TestNormal -> parsedTypeMatches isTestTreeTypeVar   TestProp -> const True   TestTodo -> parsedTypeMatches $ isTypeVarNamed (name_String names)   TestBatch -> parsedTypeMatches $ \case-    TypeList ty -> isTypeVarNamed (name_TestTree names) ty+    TypeList ty -> isTestTreeTypeVar ty     _ -> False+  TestModify modifier tt -> isValidForModifier tt modifier   where+    isValidForModifier tt = \case+      ExpectFail -> isValidForTestType names tt+      ExpectFailBecause -> isValidForTestType names tt+      IgnoreTest -> isValidForTestType names tt+      IgnoreTestBecause -> isValidForTestType names tt+     parsedTypeMatches f = maybe False f . parseSigWcType+    isTestTreeTypeVar = isTypeVarNamed (name_TestTree names)  typeForTestType :: TestType -> String typeForTestType = \case@@ -234,15 +282,57 @@   TestProp -> "(Testable prop => prop)"   TestTodo -> "String"   TestBatch -> "[TestTree]"+  TestModify modifier tt -> typeForTestModifier tt modifier+  where+    typeForTestModifier tt = \case+      ExpectFail -> typeForTestType tt+      ExpectFailBecause -> typeForTestType tt+      IgnoreTest -> typeForTestType tt+      IgnoreTestBecause -> typeForTestType tt  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 $ mkHsTyVar (name_TestTree names)+withTestModifier ::+  Monad m =>+  ExternalNames ->+  TestModifier ->+  SrcSpan ->+  [LPat GhcPs] ->+  ([LPat GhcPs] -> m (LHsExpr GhcPs)) ->+  m (LHsExpr GhcPs)+withTestModifier names modifier loc args f =+  case modifier of+    ExpectFail -> mapAllTests (mkHsVar $ name_expectFail names) <$> f args+    ExpectFailBecause ->+      case args of+        arg : rest+          | Just s <- parseLitStrPat arg ->+              mapAllTests (applyName (name_expectFailBecause names) [mkHsLitString s]) <$> f rest+        _ -> needsStrArg "_expectFailBecause"+    IgnoreTest -> mapAllTests (mkHsVar $ name_ignoreTest names) <$> f args+    IgnoreTestBecause ->+      case args of+        arg : rest+          | Just s <- parseLitStrPat arg ->+              mapAllTests (applyName (name_ignoreTestBecause names) [mkHsLitString s]) <$> f rest+        _ -> needsStrArg "_ignoreTestBecause"+  where+    needsStrArg label =+      autocollectError . unlines . concat $+        [ [label ++ " requires a String argument."]+        , case args of+            [] -> []+            arg : _ -> ["Got: " ++ showPpr arg]+        , ["At: " ++ getSpanLine loc]+        ]++    applyName name = mkHsApps (mkHsVar name)++    -- mapAllTests f e = [| map $f $e |]+    mapAllTests func expr = applyName (name_map names) [func, expr]  {----- Test converter monad -----} 

@@ -7,24 +7,35 @@ ) where  import Test.Tasty (TestTree)+import Test.Tasty.ExpectedFailure (expectFail, expectFailBecause, ignoreTest, ignoreTestBecause)  import Test.Tasty.AutoCollect.Error import Test.Tasty.AutoCollect.GHC import Test.Tasty.Ext.Todo (testTreeTodo)  data ExternalNames = ExternalNames-  { name_TestTree :: Name-  , name_testTreeTodo :: Name-  , name_String :: Name+  { name_String :: Name   , name_concat :: Name+  , name_map :: Name+  , name_TestTree :: Name+  , name_testTreeTodo :: Name+  , name_expectFail :: Name+  , name_expectFailBecause :: Name+  , name_ignoreTest :: Name+  , name_ignoreTestBecause :: Name   }  loadExternalNames :: HscEnv -> IO ExternalNames loadExternalNames env = do-  name_TestTree <- loadName ''TestTree-  name_testTreeTodo <- loadName 'testTreeTodo   name_String <- loadName ''String   name_concat <- loadName 'concat+  name_map <- loadName 'map+  name_TestTree <- loadName ''TestTree+  name_testTreeTodo <- loadName 'testTreeTodo+  name_expectFail <- loadName 'expectFail+  name_expectFailBecause <- loadName 'expectFailBecause+  name_ignoreTest <- loadName 'ignoreTest+  name_ignoreTestBecause <- loadName 'ignoreTestBecause   pure ExternalNames{..}   where     loadName name =

@@ -7,13 +7,18 @@   -- * Output helpers   showPpr, +  -- * Parsers+  parseLitStrPat,+   -- * Builders   genFuncSig,   genFuncDecl,   lhsvar,+  mkHsVar,   mkHsAppTypes,   mkHsTyVar,   mkExprTypeSig,+  mkHsLitString,    -- * Located utilities   genLoc,@@ -42,6 +47,13 @@ showPpr :: Outputable a => a -> String showPpr = showSDocUnsafe . ppr +{----- Parsers ----}++parseLitStrPat :: LPat GhcPs -> Maybe String+parseLitStrPat = \case+  L _ (LitPat _ (HsString _ s)) -> Just (unpackFS s)+  _ -> Nothing+ {----- Builders -----}  genFuncSig :: LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs@@ -63,6 +75,9 @@ lhsvar :: LocatedN RdrName -> LHsExpr GhcPs lhsvar = genLoc . HsVar NoExtField +mkHsVar :: Name -> LHsExpr GhcPs+mkHsVar = lhsvar . genLoc . getRdrName+ mkHsAppTypes :: LHsExpr GhcPs -> [LHsType GhcPs] -> LHsExpr GhcPs mkHsAppTypes = foldl' mkHsAppType @@ -72,12 +87,15 @@ mkHsTyVar :: Name -> LHsType GhcPs mkHsTyVar = genLoc . HsTyVar noAnn NotPromoted . genLoc . getRdrName --- | mkExprTypeSig <e> <t> = (<e> :: <t>)+-- | mkExprTypeSig e t = [| $e :: $t |] mkExprTypeSig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs mkExprTypeSig e t =   genLoc . ExprWithTySig noAnn e $     HsWC NoExtField (hsTypeToHsSigType t) +mkHsLitString :: String -> LHsExpr GhcPs+mkHsLitString = genLoc . HsLit noAnn . mkHsString+ {----- Located utilities -----}  genLoc :: e -> GenLocated (SrcAnn ann) e@@ -86,9 +104,9 @@ firstLocatedWhere :: Ord l => (GenLocated l e -> Maybe a) -> [GenLocated l e] -> Maybe a firstLocatedWhere f = listToMaybe . mapMaybe f . sortOn getLoc -getSpanLine :: GenLocated (SrcSpanAnn' a) e -> String+getSpanLine :: SrcSpan -> String getSpanLine loc =-  case srcSpanStart $ getLocA loc of+  case srcSpanStart loc of     Right srcLoc -> "line " ++ show (srcLocLine srcLoc)     Left s -> s 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           tasty-autocollect-version:        0.2.0.0+version:        0.3.0.0 synopsis:       Autocollection of tasty tests. description:    Autocollection of tasty tests. See README.md for more details. category:       Testing@@ -26,7 +26,12 @@     test/golden/output_group_type_tree.golden     test/golden/test_args.golden     test/golden/test_batch_args.golden+    test/golden/test_batch_expectFailBecause_output.golden     test/golden/test_batch_type.golden+    test/golden/test_expectFail_output.golden+    test/golden/test_expectFailBecause_output.golden+    test/golden/test_ignoreTest_output.golden+    test/golden/test_ignoreTestBecause_output.golden     test/golden/test_prop_bad_arg.golden     test/golden/test_prop_no_args.golden     test/golden/test_todo_args.golden@@ -64,6 +69,7 @@     , filepath >=1.4.2.1 && <2     , ghc >=8.10 && <9.3     , tasty >=1.4.2.1 && <2+    , tasty-expected-failure >=0.11 && <1     , template-haskell >=2.16 && <2.19     , text >=1.2.3.2 && <3     , transformers >=0.5.6.2 && <1

@@ -153,6 +153,15 @@   getTestLines stdout @?~ containsStripped (eq "test 1: OK")   getTestLines stdout @?~ containsStripped (eq "test 2: OK") +test =+  testCase "tests may omit type after specifying a type prior" $+    assertSuccess_ . runQCTest $+      [ "test :: TestTree"+      , "test = testCase \"test 1\" $ return ()"+      , ""+      , "test = testCase \"test 2\" $ return ()"+      ]+ {----- test_batch -----}  test = testCase "test_batch generates multiple tests" $ do@@ -220,6 +229,15 @@       ]  test =+  testCase "test_prop may omit type after specifying a different type prior" $+    assertSuccess_ . runQCTest $+      [ "test_prop :: Property"+      , "test_prop \"test 1\" = 1 === 1"+      , ""+      , "test_prop \"test 2\" x = (x :: Int) === x"+      ]++test =   testCase "test_prop uses any 'testProperty' function in scope" $ do     (stdout, _) <-       assertSuccess . runTest $@@ -256,3 +274,57 @@  addQuickCheck :: GHCProject -> GHCProject addQuickCheck proj = proj{dependencies = "tasty-quickcheck" : dependencies proj}++{----- tasty-expected-failure integration -----}++test =+  testGolden "expectFail succeeds when test fails" "test_expectFail_output.golden" $ do+    (stdout, _) <-+      assertSuccess . runTest $+        [ "test_expectFail = testCase \"failing test\" $ 1 @?= 2"+        ]+    return (normalizeTestOutput stdout)++test =+  testGolden "expectFailBecause succeeds when test fails" "test_expectFailBecause_output.golden" $ do+    (stdout, _) <-+      assertSuccess . runTest $+        [ "test_expectFailBecause \"some reason\" = testCase \"failing test\" $ 1 @?= 2"+        ]+    return (normalizeTestOutput stdout)++test =+  testGolden "ignoreTest succeeds when test fails" "test_ignoreTest_output.golden" $ do+    (stdout, _) <-+      assertSuccess . runTest $+        [ "test_ignoreTest = testCase \"failing test\" $ 1 @?= 2"+        ]+    return (normalizeTestOutput stdout)++test =+  testGolden "ignoreTestBecause succeeds when test fails" "test_ignoreTestBecause_output.golden" $ do+    (stdout, _) <-+      assertSuccess . runTest $+        [ "test_ignoreTestBecause \"some reason\" = testCase \"failing test\" $ 1 @?= 2"+        ]+    return (normalizeTestOutput stdout)++test =+  testGolden "expected-failure modifiers work on test_batch" "test_batch_expectFailBecause_output.golden" $ do+    (stdout, _) <-+      assertAnyFailure . runTest $+        [ "test_batch_expectFailBecause \"some reason\" ="+        , "  [ testCase (\"failing test #\" ++ show x) $ x @?= 1"+        , "  | x <- [1 .. 3 :: Int]"+        , "  ]"+        ]+    return (normalizeTestOutput stdout)++test =+  testCase "expected-failure modifiers work on test_prop" $ do+    (stdout, _) <-+      assertSuccess . runQCTest $+        [ "test_prop_expectFailBecause :: [Int] -> Bool"+        , "test_prop_expectFailBecause \"some reason\" \"my property\" xs = length xs < 0"+        ]+    getTestLines stdout @?~ containsStripped (eq "my property: FAIL (expected: some reason)")

@@ -0,0 +1,15 @@+Main.hs+  Test+    failing test #1: OK (unexpected: some reason)+       (unexpected success: some reason)+      Use -p '/failing test #1/' to rerun this test only.+    failing test #2: FAIL (expected: some reason)+      ./Test.hs:6:+      expected: 1+       but got: 2 (expected failure)+    failing test #3: FAIL (expected: some reason)+      ./Test.hs:6:+      expected: 1+       but got: 3 (expected failure)++1 out of 3 tests failed

@@ -0,0 +1,8 @@+Main.hs+  Test+    failing test: FAIL (expected: some reason)+      ./Test.hs:5:+      expected: 2+       but got: 1 (expected failure)++All 1 tests passed

@@ -0,0 +1,8 @@+Main.hs+  Test+    failing test: FAIL (expected)+      ./Test.hs:5:+      expected: 2+       but got: 1 (expected failure)++All 1 tests passed

@@ -0,0 +1,6 @@+Main.hs+  Test+    failing test: IGNORED+      some reason++All 1 tests passed

@@ -0,0 +1,5 @@+Main.hs+  Test+    failing test: IGNORED++All 1 tests passed