tasty-autocollect (empty) → 0.1.0.0

raw patch · 40 files changed

+3329/−0 lines, 40 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, directory, explainable-predicates, filepath, ghc, tasty, tasty-autocollect, tasty-golden, tasty-hunit, tasty-quickcheck, template-haskell, temporary, text, transformers, typed-process

Files

• CHANGELOG.md +5/−0
• LICENSE.md +11/−0
• README.md +254/−0
• exe/Preprocessor.hs +31/−0
• src/Test/Tasty/AutoCollect.hs +30/−0
• src/Test/Tasty/AutoCollect/Config.hs +127/−0
• src/Test/Tasty/AutoCollect/Constants.hs +35/−0
• src/Test/Tasty/AutoCollect/ConvertTest.hs +287/−0
• src/Test/Tasty/AutoCollect/Error.hs +13/−0
• src/Test/Tasty/AutoCollect/ExternalNames.hs +28/−0
• src/Test/Tasty/AutoCollect/GHC.hs +110/−0
• src/Test/Tasty/AutoCollect/GHC/Shim.hs +13/−0
• src/Test/Tasty/AutoCollect/GHC/Shim_8_10.hs +242/−0
• src/Test/Tasty/AutoCollect/GHC/Shim_9_0.hs +207/−0
• src/Test/Tasty/AutoCollect/GHC/Shim_9_2.hs +180/−0
• src/Test/Tasty/AutoCollect/GHC/Shim_Common.hs +72/−0
• src/Test/Tasty/AutoCollect/GenerateMain.hs +140/−0
• src/Test/Tasty/AutoCollect/ModuleType.hs +39/−0
• src/Test/Tasty/AutoCollect/Utils/Text.hs +25/−0
• src/Test/Tasty/AutoCollect/Utils/TreeMap.hs +79/−0
• src/Test/Tasty/Ext/Todo.hs +50/−0
• tasty-autocollect.cabal +134/−0
• test/Examples.hs +25/−0
• test/Main.hs +5/−0
• test/Test/Tasty/AutoCollect/ConfigTest.hs +212/−0
• test/Test/Tasty/AutoCollect/ConvertTestTest.hs +264/−0
• test/Test/Tasty/AutoCollect/GenerateMainTest.hs +271/−0
• test/Test/Tasty/AutoCollect/ModuleTypeTest.hs +43/−0
• test/Test/Tasty/AutoCollect/Utils/TreeMapTest.hs +32/−0
• test/Test/Tasty/Ext/TodoTest.hs +43/−0
• test/TestUtils/Golden.hs +14/−0
• test/TestUtils/Integration.hs +171/−0
• test/TestUtils/Predicates.hs +34/−0
• test/TestUtils/QuickCheck.hs +26/−0
• test/golden/example.golden +1/−0
• test/golden/output_group_type_flat.golden +17/−0
• test/golden/output_group_type_modules.golden +24/−0
• test/golden/output_group_type_tree.golden +27/−0
• test/golden/test_batch_args.golden +4/−0
• test/golden/test_batch_type.golden +4/−0

@@ -0,0 +1,5 @@+# Unreleased++# v0.1.0.0++Initial release

@@ -0,0 +1,11 @@+Copyright © 2022-present Brandon Chinn++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,254 @@+# tasty-autocollect++[![](https://img.shields.io/github/workflow/status/brandonchinn178/tasty-autocollect/CI/main)](https://github.com/brandonchinn178/tasty-autocollect/actions)+[![](https://img.shields.io/codecov/c/gh/brandonchinn178/tasty-autocollect)](https://app.codecov.io/gh/brandonchinn178/tasty-autocollect)+[![](https://img.shields.io/hackage/v/tasty-autocollect)](https://hackage.haskell.org/package/tasty-autocollect)++A preprocessor/compiler plugin that will automatically collect Tasty tests and generate a main file to run all the tests.++Design goals:+* 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)++## Usage++### Quickstart++1. Add the following to your `package.yaml` or `.cabal` file:++    ```yaml+    tests:+      my-library-tests:+        ghc-options: -F -pgmF=tasty-autocollect+        build-tools:+          - tasty-autocollect:tasty-autocollect+        ...+    ```+    ```cabal+    test-suite my-library-tests+      ghc-options: -F -pgmF=tasty-autocollect+      build-tool-depends:+        tasty-autocollect:tasty-autocollect+      ...+    ```++1. Write your main file to contain just:++    ```hs+    {- AUTOCOLLECT.MAIN -}+    ```++1. Write your tests:++    ```hs+    {- AUTOCOLLECT.TEST -}++    module MyTest (+      {- 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_testProperty :: [Int] -> Property+    test_testProperty "reverse . reverse === id" = \xs -> (reverse . reverse) xs === id xs++    test_goldenVsString :: IO ByteString+    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 ()+      ]+    ```++### How it works++The `package.yaml`/`.cabal` snippet registers `tasty-autocollect` as a preprocessor, which does one of three things at the very beginning of compilation:++1. If the file contains `{- AUTOCOLLECT.MAIN -}`, find all test modules and generate a main module.+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+```++### Configuration++`tasty-autocollect` can be configured by adding `k = v` lines to the same block comment as `AUTOCOLLECT.MAIN`; e.g.++```hs+{- AUTOCOLLECT.MAIN+suite_name = foo+-}+```++* `suite_name`: The name to use in the `testGroup` at the root of the test suite `TestTree` (defaults to the path of the main file)++* `group_type`: How the tests should be grouped (defaults to `modules`)+    * `flat`: All the tests are in the same namespace+        ```+        Main.hs+          test 1: OK+          test 2: OK+          test 3: OK+        ```++    * `modules`: Tests are grouped by their module+        ```+        Main.hs+          Test.Module1+            test1: OK+            test2: OK+          Test.Module2+            test3: OK+        ```++    * `tree`: Tests are grouped by their module, which is broken out into a tree+        ```+        Main.hs+          Test+            Module1+              test1: OK+              test2: OK+            Module2+              test3: OK+        ```++* `strip_suffix`: The suffix to strip from a test module, e.g. `strip_suffix = Test` will relabel a `Foo.BarTest` module to `Foo.Bar`++* `ingredients`: A comma-separated list of extra tasty ingredients to include, e.g.++    ```+    ingredients = SomeLibrary.ingredient1, SomeLibrary.ingredient2+    ```++* `ingredients_override`: By default, `ingredients` will add the ingredients in front of the default `tasty` ingredients. When `true`, does not automatically include the default `tasty` ingredients, for complete control over the ingredient order.++### 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++## Features++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.++### 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 @?= ...+```++### Defining batches of tests++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]+  ]+```++is equivalent to writing:++```hs+test_testCase :: Assertion+test_testCase "test #1" = return ()++test_testCase :: Assertion+test_testCase "test #5" = return ()++test_testCase :: Assertion+test_testCase "test #10" = return ()+```++## Comparison with `tasty-discover`++Advantages:+* Supports test functions with multiple arguments (e.g. `tasty-golden`)+* Avoids hardcoding testers like `unit_` or `prop_`+* Avoids rewriting test label twice in function name+* Avoids test name restrictions+    * Because `tasty-discover` couples the function name with the test label, you can't do things like use punctuation in the test label. So `tasty-discover` doesn't allow writing the equivalent of `testProperty "reverse . reverse === id"`.+* More features out-of-the-box (see "Features" section)+* More configurable+    * More configuration options+    * Configuration is more extensible, since configuration is parsed from a comment in the main module instead of as preprocessor arguments++Disadvantages:+* Uses both a preprocessor and a plugin (`tasty-discover` only uses a preprocessor)+    * Haven't tested performance yet, but I wouldn't be surprised if there's a non-negligible performance cost

@@ -0,0 +1,31 @@+{-# LANGUAGE LambdaCase #-}++{- |+A preprocessor that registers tasty-autocollect in a test suite.++We need to use a preprocessor for Main.hs because GHC plugins don't+seem to support dynamically registering other modules as imports (GHC+already knows what order it's going to compile the modules in, because+plugins run per module).++But GHC's plugin interface is much nicer for rewriting test files, so+what we'll do here is:++1. Always register the plugin by adding `{\-# OPTIONS_GHC -fplugin=... #-\}` to+   the top of the file. The plugin will then inspect the file to see if it's+   a test file, and if so, convert the test module.++2. If the file is the main file, generate the main file and write a new file.+-}+module Main where++import qualified Data.Text.IO as Text+import System.Environment (getArgs)+import Test.Tasty.AutoCollect (processFile)++main :: IO ()+main =+  getArgs >>= \case+    -- https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/phases.html#options-affecting-a-haskell-pre-processor+    [fp, input, output] -> Text.readFile input >>= processFile fp >>= Text.writeFile output+    _ -> error "The tasty-autocollect preprocessor does not accept any additional arguments."

@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Tasty.AutoCollect (+  processFile,+) where++import Data.Text (Text)+import qualified Data.Text as Text++import Test.Tasty.AutoCollect.GenerateMain+import Test.Tasty.AutoCollect.ModuleType+import Test.Tasty.AutoCollect.Utils.Text++-- | Preprocess the given Haskell file. See Preprocessor.hs+processFile :: FilePath -> Text -> IO Text+processFile path file =+  case parseModuleType file of+    Just (ModuleMain cfg) -> generateMainModule cfg path+    Just ModuleTest ->+      pure . Text.unlines $+        [ "{-# OPTIONS_GHC -fplugin=Test.Tasty.AutoCollect.ConvertTest #-}"+        , file'+        ]+    Nothing -> pure file'+  where+    file' =+      Text.unlines+        [ "{-# LINE 1 " <> quoted (Text.pack path) <> " #-}"+        , file+        ]

@@ -0,0 +1,127 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Tasty.AutoCollect.Config (+  AutoCollectConfig (..),+  AutoCollectGroupType (..),+  defaultConfig,+  parseConfig,+) where++import Data.Text (Text)+import qualified Data.Text as Text++{----- Configuration -----}++-- | Configuration for generating the Main module, specified as a block comment.+data AutoCollectConfig = AutoCollectConfig+  { cfgSuiteName :: Maybe Text+  -- ^ The name of the entire test suite+  , cfgGroupType :: AutoCollectGroupType+  -- ^ How tests should be grouped (defaults to "modules")+  , cfgStripSuffix :: Text+  -- ^ The suffix to strip from a test, e.g. @strip_suffix = Test@ will relabel+  -- a module @Foo.BarTest@ to @Foo.Bar@.+  , cfgIngredients :: [Text]+  -- ^ A comma-separated list of extra tasty ingredients to include+  , cfgIngredientsOverride :: Bool+  -- ^ If true, 'cfgIngredients' overrides the default tasty ingredients;+  -- otherwise, they're prepended to the list of default ingredients (defaults to false)+  }+  deriving (Show, Eq)++data AutoCollectGroupType+  = -- | All tests will be flattened like+    --+    -- @+    -- test1+    -- test2+    -- test3+    -- @+    AutoCollectGroupFlat+  | -- | Tests will be grouped by module+    --+    -- @+    -- MyModule.MyTest1+    --   test1+    --   test2+    -- MyModule.MyTest2+    --   test3+    -- @+    AutoCollectGroupModules+  | -- | Test modules will be grouped as a tree+    --+    -- @+    -- MyModule+    --   MyTest1+    --     test1+    --     test2+    --   MyTest2+    --     test3+    -- @+    AutoCollectGroupTree+  deriving (Show, Eq)++defaultConfig :: AutoCollectConfig+defaultConfig =+  AutoCollectConfig+    { cfgSuiteName = Nothing+    , cfgGroupType = AutoCollectGroupModules+    , cfgIngredients = []+    , cfgIngredientsOverride = False+    , cfgStripSuffix = ""+    }++parseConfig :: Text -> Either Text AutoCollectConfig+parseConfig = fmap resolve . mapM parseLine . filter (not . isIgnoredLine) . Text.lines+  where+    isIgnoredLine s = Text.null (Text.strip s) || ("#" `Text.isPrefixOf` s)++    parseLine :: Text -> Either Text (AutoCollectConfig -> AutoCollectConfig)+    parseLine s = do+      (k, v) <-+        case Text.splitOn "=" s of+          [Text.strip -> k, Text.strip -> v]+            | not (Text.null k)+            , not (Text.null v) ->+                pure (k, v)+          _ -> Left $ "Invalid configuration line: " <> Text.pack (show s)++      case k of+        "suite_name" ->+          pure $ \cfg -> cfg{cfgSuiteName = Just v}+        "group_type" -> do+          groupType <- parseGroupType v+          pure $ \cfg -> cfg{cfgGroupType = groupType}+        "strip_suffix" ->+          pure $ \cfg -> cfg{cfgStripSuffix = v}+        "ingredients" -> do+          let ingredients = map Text.strip . Text.splitOn "," $ v+          pure $ \cfg -> cfg{cfgIngredients = ingredients}+        "ingredients_override" -> do+          override <- parseBool v+          pure $ \cfg -> cfg{cfgIngredientsOverride = override}+        _ -> Left $ "Invalid configuration key: " <> Text.pack (show k)++    resolve fs = compose fs defaultConfig++parseGroupType :: Text -> Either Text AutoCollectGroupType+parseGroupType = \case+  "flat" -> pure AutoCollectGroupFlat+  "modules" -> pure AutoCollectGroupModules+  "tree" -> pure AutoCollectGroupTree+  ty -> Left $ "Invalid group_type: " <> Text.pack (show ty)++parseBool :: Text -> Either Text Bool+parseBool s =+  case Text.toLower s of+    "true" -> pure True+    "false" -> pure False+    _ -> Left $ "Invalid bool: " <> Text.pack (show s)++{----- Utilities -----}++-- | [f, g, h] => (h . g . f)+compose :: [a -> a] -> a -> a+compose fs = foldr (\f acc -> acc . f) id fs

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Tasty.AutoCollect.Constants (+  testListIdentifier,+  testIdentifier,+  isMainComment,+  isTestComment,+  isTestExportComment,+) where++import Data.Char (toLower)+import qualified Data.Text as Text++import Test.Tasty.AutoCollect.Utils.Text++testListIdentifier :: String+testListIdentifier = "tasty_autocollect_tests"++testIdentifier :: Int -> String+testIdentifier x = "tasty_autocollect_test_" ++ show x++isMainComment :: String -> Bool+isMainComment = matches "autocollect.main"++isTestComment :: String -> Bool+isTestComment = matches "autocollect.test"++isTestExportComment :: String -> Bool+isTestExportComment = matches "autocollect.test.export" . unwrap+  where+    -- Support '{- $autocollect.test.export$ -}' for Ormolu/Fourmolu support+    unwrap = Text.unpack . withoutPrefix "$" . withoutSuffix "$" . Text.pack++matches :: String -> String -> Bool+matches label s = map toLower s == label

@@ -0,0 +1,287 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Tasty.AutoCollect.ConvertTest (+  plugin,+) where++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++import Test.Tasty.AutoCollect.Constants+import Test.Tasty.AutoCollect.Error+import Test.Tasty.AutoCollect.ExternalNames+import Test.Tasty.AutoCollect.GHC++-- | The plugin to convert a test file. Injected by the preprocessor.+plugin :: Plugin+plugin =+  setKeepRawTokenStream+    defaultPlugin+      { pluginRecompile = purePlugin+      , parsedResultAction = \_ _ modl -> do+          env <- getHscEnv+          names <- liftIO $ loadExternalNames env+          pure $ transformTestModule names modl+      }++{- |+Transforms a test module of the form++@+{\- AUTOCOLLECT.TEST -\}+module MyTest (+  foo,+  {\- AUTOCOLLECT.TEST.export -\}+  bar,+) where++test_<tester> :: <type>+test_<tester> <name> <other args> = <test>+@++to the equivalent of++@+module MyTest (+  foo,+  tests,+  bar,+) where++tests :: [TestTree]+tests = [test1]++test1 :: TestTree+test1 = <tester> <name> <other args> (<test> :: <type>)+@+-}+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+       in modl+            { hsmodExports = updateExports <$> hsmodExports modl+            , hsmodDecls = mkTestsList testNames ++ decls+            }++    -- Replace "{- AUTOCOLLECT.TEST.export -}" with `tests` in the export list+    updateExports lexports+      | Just exportSpan <- firstLocatedWhere getTestExportAnnSrcSpan (getExportComments parsedModl lexports) =+          (L (toSrcAnnA exportSpan) exportIE :) <$> lexports+      | otherwise =+          lexports+    getTestExportAnnSrcSpan (L loc comment) =+      if isTestExportComment comment+        then Just loc+        else Nothing+    exportIE = IEVar NoExtField $ genLoc $ IEName testListName++    -- Generate the `tests` list+    mkTestsList :: [LocatedN RdrName] -> [LHsDecl GhcPs]+    mkTestsList testNames =+      let testsList = genLoc $ mkExplicitList $ map lhsvar testNames+       in [ genLoc $ genFuncSig testListName $ getListOfTestTreeType names+          , genLoc $ genFuncDecl testListName [] (flattenTestList testsList) Nothing+          ]++    flattenTestList testsList =+      mkHsApp (lhsvar $ mkLRdrName "concat") $+        genLoc . ExprWithTySig noAnn testsList $+          HsWC NoExtField . hsTypeToHsSigType . 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]+    Just (FuncSig [funcName] ty)+      | Just testType <- parseTestType funcName -> do+          testName <- getNextTestName+          setLastSeenSig+            SigInfo+              { testType+              , testName+              , testHsType = ty+              }+          pure (genFuncSig testName (getListOfTestTreeType names) <$ loc)+    -- e.g. test_testCase "test name" = <body>+    -- =>   test1 = [testCase "test name" (<body> :: Assertion)]+    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)++          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+                  ]++          -- 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 (genFuncDecl testName [] testBody (Just funcDefWhereClause) <$ loc)+    -- anything else leave unmodified+    _ -> pure loc++{- |+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))++-- | Identifier for the generated `tests` list.+testListName :: LocatedN RdrName+testListName = mkLRdrName testListIdentifier++data TestType+  = TestSingle Tester+  | TestBatch+  deriving (Show, Eq)++data Tester+  = Tester String+  | TesterTodo+  deriving (Show, Eq)++parseTestType :: LocatedN RdrName -> Maybe TestType+parseTestType = fmap toTestType . stripPrefix "test_" . fromRdrName+  where+    toTestType = \case+      "batch" -> TestBatch+      "todo" -> TestSingle TesterTodo+      s -> TestSingle (Tester s)++fromTester :: ExternalNames -> Tester -> RdrName+fromTester names = \case+  Tester name -> mkRdrName name+  TesterTodo -> getRdrName $ name_testTreeTodo names++-- | 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)++{----- Test converter monad -----}++type ConvertTestM = State ConvertTestState++data ConvertTestState = ConvertTestState+  { lastSeenSig :: Maybe SigInfo+  , allTests :: Seq (LocatedN RdrName)+  }++data SigInfo = SigInfo+  { testType :: TestType+  -- ^ The parsed tester+  , testName :: LocatedN RdrName+  -- ^ The generated name for the test+  , testHsType :: LHsSigWcType GhcPs+  -- ^ The type of the test body+  }++runConvertTestM :: ConvertTestM a -> (a, [LocatedN RdrName])+runConvertTestM m =+  fmap (toList . allTests) . State.runState m $+    ConvertTestState+      { lastSeenSig = Nothing+      , allTests = Seq.Empty+      }++getLastSeenSig :: ConvertTestM (Maybe SigInfo)+getLastSeenSig = do+  state@ConvertTestState{lastSeenSig} <- State.get+  State.put state{lastSeenSig = Nothing}+  pure lastSeenSig++setLastSeenSig :: SigInfo -> ConvertTestM ()+setLastSeenSig info = State.modify' $ \state -> state{lastSeenSig = Just info}++getNextTestName :: ConvertTestM (LocatedN RdrName)+getNextTestName = do+  state@ConvertTestState{allTests} <- State.get+  let nextTestName = mkLRdrName $ testIdentifier (length allTests)+  State.put state{allTests = allTests Seq.|> nextTestName}+  pure nextTestName

@@ -0,0 +1,13 @@+module Test.Tasty.AutoCollect.Error (+  autocollectError,+) where++import Test.Tasty.AutoCollect.GHC++autocollectError :: String -> a+autocollectError msg =+  pgmError . unlines $+    [ ""+    , "******************** tasty-autocollect failure ********************"+    , msg+    ]

@@ -0,0 +1,28 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++module Test.Tasty.AutoCollect.ExternalNames (+  ExternalNames (..),+  loadExternalNames,+) where++import Test.Tasty (TestTree)++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+  }++loadExternalNames :: HscEnv -> IO ExternalNames+loadExternalNames env = do+  name_TestTree <- loadName ''TestTree+  name_testTreeTodo <- loadName 'testTreeTodo+  pure ExternalNames{..}+  where+    loadName name =+      thNameToGhcNameIO env (hsc_NC env) name+        >>= maybe (autocollectError $ "Could not get Name for " ++ show name) return

@@ -0,0 +1,110 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Tasty.AutoCollect.GHC (+  module Test.Tasty.AutoCollect.GHC.Shim,++  -- * Builders+  genFuncSig,+  genFuncDecl,+  lhsvar,+  mkHsAppTypes,++  -- * Located utilities+  genLoc,+  firstLocatedWhere,+  getSpanLine,++  -- * Name utilities+  mkRdrName,+  mkLRdrName,+  mkRdrNameType,+  mkLRdrNameType,+  fromRdrName,+  thNameToGhcNameIO,+) where++import Data.Foldable (foldl')+import Data.IORef (IORef)+import Data.List (sortOn)+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import qualified Language.Haskell.TH as TH++import Test.Tasty.AutoCollect.GHC.Shim++{----- Builders -----}++genFuncSig :: LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs+genFuncSig funcName funcType =+  SigD noExtField+    . TypeSig noAnn [funcName]+    . hsTypeToHsSigWcType+    $ funcType++-- | Make simple function declaration of the form `<funcName> <funcArgs> = <funcBody> where <funcWhere>`+genFuncDecl :: LocatedN RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> Maybe (HsLocalBinds GhcPs) -> HsDecl GhcPs+genFuncDecl funcName funcArgs funcBody mFuncWhere =+  ValD NoExtField . mkFunBind Generated funcName $+    [ mkMatch (mkPrefixFunRhs funcName) funcArgs funcBody funcWhere+    ]+  where+    funcWhere = fromMaybe emptyLocalBinds mFuncWhere++lhsvar :: LocatedN RdrName -> LHsExpr GhcPs+lhsvar = genLoc . HsVar NoExtField++mkHsAppTypes :: LHsExpr GhcPs -> [LHsType GhcPs] -> LHsExpr GhcPs+mkHsAppTypes = foldl' mkHsAppType++mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs+mkHsAppType e t = genLoc $ HsAppType xAppTypeE e (HsWC noExtField t)++{----- Located utilities -----}++genLoc :: e -> GenLocated (SrcAnn ann) e+genLoc = L generatedSrcAnn++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 loc =+  case srcSpanStart $ getLocA loc of+    Right srcLoc -> "line " ++ show (srcLocLine srcLoc)+    Left s -> s++{----- Name utilities -----}++mkRdrName :: String -> RdrName+mkRdrName = mkRdrUnqual . mkOccNameVar++mkLRdrName :: String -> LocatedN RdrName+mkLRdrName = genLoc . mkRdrName++mkRdrNameType :: String -> RdrName+mkRdrNameType = mkRdrUnqual . mkOccNameTC++mkLRdrNameType :: String -> LocatedN RdrName+mkLRdrNameType = genLoc . mkRdrNameType++fromRdrName :: LocatedN RdrName -> String+fromRdrName = occNameString . rdrNameOcc . unLoc++-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/8492+thNameToGhcNameIO :: HscEnv -> IORef NameCache -> TH.Name -> IO (Maybe Name)+thNameToGhcNameIO hscEnv cache name =+  fmap fst+    . runCoreM+      hscEnv{hsc_NC = cache}+      (unused "cr_rule_base")+      (strict '.')+      (unused "cr_module")+      (strict mempty)+      (unused "cr_print_unqual")+      (unused "cr_loc")+    $ thNameToGhcName name+  where+    unused msg = error $ "unexpectedly used: " ++ msg++    -- marks fields that are strict, so we can't use `unused`+    strict = id

@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}++module Test.Tasty.AutoCollect.GHC.Shim (module X) where++-- GHC-specific shims+import Test.Tasty.AutoCollect.GHC.Shim_Common as X+#if __GLASGOW_HASKELL__ == 810+import Test.Tasty.AutoCollect.GHC.Shim_8_10 as X+#elif __GLASGOW_HASKELL__ == 900+import Test.Tasty.AutoCollect.GHC.Shim_9_0 as X+#elif __GLASGOW_HASKELL__ == 902+import Test.Tasty.AutoCollect.GHC.Shim_9_2 as X+#endif

@@ -0,0 +1,242 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Tasty.AutoCollect.GHC.Shim_8_10 (+  -- * Re-exports+  module X,++  -- * Compat++  -- ** Plugin+  setKeepRawTokenStream,++  -- ** Annotations+  getExportComments,+  generatedSrcAnn,+  toSrcAnnA,++  -- ** SrcSpan+  srcSpanStart,++  -- ** OccName+  mkOccNameVar,+  mkOccNameTC,++  -- ** Decl+  parseDecl,++  -- ** Type+  parseSigWcType,+  parseType,++  -- ** Pat+  parsePat,++  -- ** Expr+  mkExplicitList,+  mkExplicitTuple,+  xAppTypeE,++  -- * Backports+  SrcAnn,+  SrcSpanAnn',+  LocatedN,+  unLoc,+  getLoc,+  getLocA,+  mkHsApps,+  mkMatch,+  noAnn,+  hsTypeToHsSigType,+  hsTypeToHsSigWcType,+) where++-- 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 HscMain as X (getHscEnv)+import NameCache as X (NameCache)++import ApiAnnotation (getAnnotationComments)+import Data.Foldable (foldl')+import Data.Maybe (mapMaybe)+import qualified Data.Text as Text+import qualified GHC.Hs.Utils as GHC (mkMatch)+import qualified OccName as NameSpace (tcName, varName)+import qualified SrcLoc as GHC (srcSpanStart)++import Test.Tasty.AutoCollect.GHC.Shim_Common+import Test.Tasty.AutoCollect.Utils.Text++{----- Compat / Plugin -----}++setKeepRawTokenStream :: Plugin -> Plugin+setKeepRawTokenStream plugin =+  plugin+    { dynflagsPlugin = \_ df ->+        pure $ df `gopt_set` Opt_KeepRawTokenStream+    }++{----- Compat / Annotations -----}++-- | Get the contents of all comments in the given hsmodExports list.+getExportComments :: HsParsedModule -> Located [LIE GhcPs] -> [RealLocated String]+getExportComments parsedModl = map fromRLAnnotationComment . getCommentsAt . getLoc+  where+    getCommentsAt = mapMaybe toRealLocated . getAnnotationComments (hpm_annotations parsedModl)+    toRealLocated = \case+      L (RealSrcSpan l) e -> Just (L l e)+      L (UnhelpfulSpan _) _ -> Nothing+    fromRLAnnotationComment (L rss comment) =+      L rss $ (Text.unpack . Text.strip . unwrap) comment+    unwrap = \case+      AnnDocCommentNext s -> withoutPrefix "-- |" $ Text.pack s+      AnnDocCommentPrev s -> withoutPrefix "-- ^" $ Text.pack s+      AnnDocCommentNamed s -> withoutPrefix "-- $" $ Text.pack s+      AnnDocSection _ s -> Text.pack s+      AnnDocOptions s -> Text.pack s+      AnnLineComment s -> withoutPrefix "--" $ Text.pack s+      AnnBlockComment s -> withoutPrefix "{-" . withoutSuffix "-}" $ Text.pack s++generatedSrcAnn :: SrcSpan+generatedSrcAnn = UnhelpfulSpan (fsLit "<generated>")++toSrcAnnA :: RealSrcSpan -> SrcSpan+toSrcAnnA = RealSrcSpan++{----- Compat / SrcSpan -----}++srcSpanStart :: SrcSpan -> Either String RealSrcLoc+srcSpanStart ss =+  case GHC.srcSpanStart ss of+    RealSrcLoc srcLoc -> Right srcLoc+    UnhelpfulLoc s -> Left $ unpackFS s++{----- Compat / OccName -----}++mkOccNameVar :: String -> OccName+mkOccNameVar = mkOccName NameSpace.varName++mkOccNameTC :: String -> OccName+mkOccNameTC = mkOccName NameSpace.tcName++{----- Compat / Decl -----}++parseDecl :: LHsDecl GhcPs -> Maybe ParsedDecl+parseDecl (L _ decl) =+  case decl of+    SigD _ (TypeSig _ names ty) -> Just $ FuncSig names ty+    ValD _ (FunBind _ name matchGroup _ _) ->+      Just . FuncDef name $+        case matchGroup of+          MG{mg_alts = L _ matches} -> map (fmap parseFuncSingleDef) matches+          XMatchGroup x -> noExtCon x+    _ -> Nothing+  where+    parseFuncSingleDef = \case+      Match{m_pats, m_grhss = GRHSs _ bodys whereClause} ->+        FuncSingleDef+          { funcDefArgs = m_pats+          , funcDefGuards = map (parseFuncGuardedBody . unLoc) bodys+          , funcDefWhereClause = unLoc whereClause+          }+      Match{m_grhss = XGRHSs x} -> noExtCon x+      XMatch x -> noExtCon x+    parseFuncGuardedBody = \case+      GRHS _ guards body -> FuncGuardedBody guards body+      XGRHS x -> noExtCon x++{----- Compat / Type -----}++parseSigWcType :: LHsSigWcType GhcPs -> Maybe ParsedType+parseSigWcType = \case+  HsWC _ (HsIB _ ltype) -> parseType ltype+  HsWC _ (XHsImplicitBndrs x) -> noExtCon x+  XHsWildCardBndrs x -> noExtCon x++parseType :: LHsType GhcPs -> Maybe ParsedType+parseType (L _ ty) =+  case ty of+    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 -----}++mkExplicitList :: [LHsExpr GhcPs] -> HsExpr GhcPs+mkExplicitList = ExplicitList noExtField Nothing++mkExplicitTuple :: [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs+mkExplicitTuple = ExplicitTuple noAnn . map (L generatedSrcAnn)++xAppTypeE :: XAppTypeE GhcPs+xAppTypeE = noExtField++{----- Backports -----}++type SrcAnn ann = SrcSpan+type SrcSpanAnn' a = SrcSpan+type LocatedN = Located++unLoc :: GenLocated l e -> e+unLoc (L _ e) = e++getLoc :: GenLocated l e -> l+getLoc (L l _) = l++getLocA :: Located e -> SrcSpan+getLocA = getLoc++mkHsApps :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs+mkHsApps = foldl' mkHsApp++mkMatch :: HsMatchContext RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> HsLocalBinds GhcPs -> LMatch GhcPs (LHsExpr GhcPs)+mkMatch ctxt pats expr lbinds = GHC.mkMatch ctxt pats expr (L generatedSrcAnn lbinds)++noAnn :: NoExtField+noAnn = NoExtField++hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs+hsTypeToHsSigType = mkLHsSigType++hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs+hsTypeToHsSigWcType = mkLHsSigWcType

@@ -0,0 +1,207 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Tasty.AutoCollect.GHC.Shim_9_0 (+  -- * Re-exports+  module X,++  -- * Compat++  -- ** Plugin+  setKeepRawTokenStream,++  -- ** Annotations+  getExportComments,+  generatedSrcAnn,+  toSrcAnnA,++  -- ** SrcSpan+  srcSpanStart,++  -- ** OccName+  mkOccNameVar,+  mkOccNameTC,++  -- ** Decl+  parseDecl,++  -- ** Type+  parseSigWcType,+  parseType,++  -- ** Pat+  parsePat,++  -- ** Expr+  mkExplicitList,+  mkExplicitTuple,+  xAppTypeE,++  -- * Backports+  SrcAnn,+  SrcSpanAnn',+  LocatedN,+  getLocA,+  mkMatch,+  noAnn,+  hsTypeToHsSigType,+  hsTypeToHsSigWcType,+) where++-- Re-exports+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.Types.Name.Cache as X (NameCache)++import qualified Data.Text as Text+import qualified GHC.Hs.Utils as GHC (mkMatch)+import GHC.Parser.Annotation (getAnnotationComments)+import qualified GHC.Types.Name.Occurrence as NameSpace (tcName, varName)+import qualified GHC.Types.SrcLoc as GHC (srcSpanStart)++import Test.Tasty.AutoCollect.GHC.Shim_Common+import Test.Tasty.AutoCollect.Utils.Text++{----- Compat / Plugin -----}++setKeepRawTokenStream :: Plugin -> Plugin+setKeepRawTokenStream plugin =+  plugin+    { dynflagsPlugin = \_ df ->+        pure $ df `gopt_set` Opt_KeepRawTokenStream+    }++{----- Compat / Annotations -----}++-- | Get the contents of all comments in the given hsmodExports list.+getExportComments :: HsParsedModule -> Located [LIE GhcPs] -> [RealLocated String]+getExportComments parsedModl = map fromRLAnnotationComment . getCommentsAt . getLoc+  where+    getCommentsAt = \case+      RealSrcSpan x _ -> getAnnotationComments (hpm_annotations parsedModl) x+      UnhelpfulSpan _ -> []+    fromRLAnnotationComment (L rss comment) =+      L rss $ (Text.unpack . Text.strip . unwrap) comment+    unwrap = \case+      AnnDocCommentNext s -> withoutPrefix "-- |" $ Text.pack s+      AnnDocCommentPrev s -> withoutPrefix "-- ^" $ Text.pack s+      AnnDocCommentNamed s -> withoutPrefix "-- $" $ Text.pack s+      AnnDocSection _ s -> Text.pack s+      AnnDocOptions s -> Text.pack s+      AnnLineComment s -> withoutPrefix "--" $ Text.pack s+      AnnBlockComment s -> withoutPrefix "{-" . withoutSuffix "-}" $ Text.pack s++generatedSrcAnn :: SrcSpan+generatedSrcAnn = generatedSrcSpan++toSrcAnnA :: RealSrcSpan -> SrcSpan+toSrcAnnA x = RealSrcSpan x Nothing++{----- Compat / SrcSpan -----}++srcSpanStart :: SrcSpan -> Either String RealSrcLoc+srcSpanStart ss =+  case GHC.srcSpanStart ss of+    RealSrcLoc srcLoc _ -> Right srcLoc+    UnhelpfulLoc s -> Left $ unpackFS s++{----- Compat / OccName -----}++mkOccNameVar :: String -> OccName+mkOccNameVar = mkOccName NameSpace.varName++mkOccNameTC :: String -> OccName+mkOccNameTC = mkOccName NameSpace.tcName++{----- Compat / Decl -----}++parseDecl :: LHsDecl GhcPs -> Maybe ParsedDecl+parseDecl (L _ decl) =+  case decl of+    SigD _ (TypeSig _ names ty) -> Just $ FuncSig names ty+    ValD _ (FunBind _ name MG{mg_alts = L _ matches} _) ->+      Just $ FuncDef name $ map (fmap parseFuncSingleDef) matches+    _ -> Nothing+  where+    parseFuncSingleDef Match{m_pats, m_grhss = GRHSs _ bodys whereClause} =+      FuncSingleDef+        { funcDefArgs = m_pats+        , funcDefGuards = map parseFuncGuardedBody bodys+        , funcDefWhereClause = unLoc whereClause+        }+    parseFuncGuardedBody (L _ (GRHS _ guards body)) =+      FuncGuardedBody guards body++{----- Compat / Type -----}++parseSigWcType :: LHsSigWcType GhcPs -> Maybe ParsedType+parseSigWcType (HsWC _ (HsIB _ ltype)) = parseType ltype++parseType :: LHsType GhcPs -> Maybe ParsedType+parseType (L _ ty) =+  case ty of+    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 -----}++mkExplicitList :: [LHsExpr GhcPs] -> HsExpr GhcPs+mkExplicitList = ExplicitList noExtField Nothing++mkExplicitTuple :: [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs+mkExplicitTuple = ExplicitTuple noAnn . map (L generatedSrcAnn)++xAppTypeE :: XAppTypeE GhcPs+xAppTypeE = noExtField++{----- Backports -----}++type SrcAnn ann = SrcSpan+type SrcSpanAnn' a = SrcSpan+type LocatedN = Located++getLocA :: Located e -> SrcSpan+getLocA = getLoc++mkMatch :: HsMatchContext GhcPs -> [LPat GhcPs] -> LHsExpr GhcPs -> HsLocalBinds GhcPs -> LMatch GhcPs (LHsExpr GhcPs)+mkMatch ctxt pats expr lbinds = GHC.mkMatch ctxt pats expr (L generatedSrcAnn lbinds)++noAnn :: NoExtField+noAnn = NoExtField++hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs+hsTypeToHsSigType = mkLHsSigType++hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs+hsTypeToHsSigWcType = mkLHsSigWcType

@@ -0,0 +1,180 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Tasty.AutoCollect.GHC.Shim_9_2 (+  -- * Re-exports+  module X,++  -- * Compat++  -- ** Plugin+  setKeepRawTokenStream,++  -- ** Annotations+  generatedSrcAnn,+  getExportComments,+  toSrcAnnA,++  -- ** SrcSpan+  srcSpanStart,++  -- ** OccName+  mkOccNameVar,+  mkOccNameTC,++  -- ** Decl+  parseDecl,++  -- ** Type+  parseSigWcType,+  parseType,++  -- ** Pat+  parsePat,++  -- ** Expr+  mkExplicitList,+  mkExplicitTuple,+  xAppTypeE,+) where++-- 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.Types.Name.Cache as X (NameCache)++import qualified Data.Text as Text+import qualified GHC.Types.Name.Occurrence as NameSpace (tcName, varName)+import qualified GHC.Types.SrcLoc as GHC (srcSpanStart)++import Test.Tasty.AutoCollect.GHC.Shim_Common+import Test.Tasty.AutoCollect.Utils.Text++{----- Compat / Plugin -----}++setKeepRawTokenStream :: Plugin -> Plugin+setKeepRawTokenStream plugin =+  plugin+    { driverPlugin = \_ env ->+        pure+          env+            { hsc_dflags = hsc_dflags env `gopt_set` Opt_KeepRawTokenStream+            }+    }++{----- Compat / Annotations -----}++-- | Get the contents of all comments in the given hsmodExports list.+getExportComments :: HsParsedModule -> LocatedL [LIE GhcPs] -> [RealLocated String]+getExportComments _ = map fromLEpaComment . priorComments . epAnnComments . ann . getLoc+  where+    fromLEpaComment (L Anchor{anchor} EpaComment{ac_tok}) =+      L anchor $ (Text.unpack . Text.strip . unwrap) ac_tok+    unwrap = \case+      EpaDocCommentNext s -> withoutPrefix "-- |" $ Text.pack s+      EpaDocCommentPrev s -> withoutPrefix "-- ^" $ Text.pack s+      EpaDocCommentNamed s -> withoutPrefix "-- $" $ Text.pack s+      EpaDocSection _ s -> Text.pack s+      EpaDocOptions s -> Text.pack s+      EpaLineComment s -> withoutPrefix "--" $ Text.pack s+      EpaBlockComment s -> withoutPrefix "{-" . withoutSuffix "-}" $ Text.pack s+      EpaEofComment -> ""++generatedSrcAnn :: SrcAnn ann+generatedSrcAnn = SrcSpanAnn noAnn generatedSrcSpan++toSrcAnnA :: RealSrcSpan -> SrcSpanAnnA+toSrcAnnA rss = SrcSpanAnn noAnn (RealSrcSpan rss Nothing)++{----- Compat / SrcSpan -----}++srcSpanStart :: SrcSpan -> Either String RealSrcLoc+srcSpanStart ss =+  case GHC.srcSpanStart ss of+    RealSrcLoc srcLoc _ -> Right srcLoc+    UnhelpfulLoc s -> Left $ unpackFS s++{----- Compat / OccName -----}++mkOccNameVar :: String -> OccName+mkOccNameVar = mkOccName NameSpace.varName++mkOccNameTC :: String -> OccName+mkOccNameTC = mkOccName NameSpace.tcName++{----- Compat / Decl -----}++parseDecl :: LHsDecl GhcPs -> Maybe ParsedDecl+parseDecl (L _ decl) =+  case decl of+    SigD _ (TypeSig _ names ty) -> Just $ FuncSig names ty+    ValD _ (FunBind _ name MG{mg_alts = L _ matches} _) ->+      Just $ FuncDef name $ map (fmap parseFuncSingleDef) matches+    _ -> Nothing+  where+    parseFuncSingleDef Match{m_pats, m_grhss = GRHSs _ bodys whereClause} =+      FuncSingleDef+        { funcDefArgs = m_pats+        , funcDefGuards = map parseFuncGuardedBody bodys+        , funcDefWhereClause = whereClause+        }+    parseFuncGuardedBody (L _ (GRHS _ guards body)) =+      FuncGuardedBody guards body++{----- Compat / Type -----}++parseSigWcType :: LHsSigWcType GhcPs -> Maybe ParsedType+parseSigWcType (HsWC _ (L _ (HsSig _ _ ltype))) = parseType ltype++parseType :: LHsType GhcPs -> Maybe ParsedType+parseType (L _ ty) =+  case ty of+    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 -----}++mkExplicitList :: [LHsExpr GhcPs] -> HsExpr GhcPs+mkExplicitList = ExplicitList noAnn++mkExplicitTuple :: [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs+mkExplicitTuple = ExplicitTuple noAnn++xAppTypeE :: XAppTypeE GhcPs+xAppTypeE = generatedSrcSpan

@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}++module Test.Tasty.AutoCollect.GHC.Shim_Common (+  ParsedDecl (..),+  FuncSingleDef (..),+  FuncGuardedBody (..),+  ParsedType (..),+  ParsedPat (..),+  ConstructorDetails (..),+) where++import GHC.Hs+#if __GLASGOW_HASKELL__ == 810+import BasicTypes (Boxity, PromotionFlag)+import RdrName (RdrName)+import SrcLoc (Located)+#elif __GLASGOW_HASKELL__ == 900+import GHC.Types.Basic (Boxity, 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.Name.Reader (RdrName)+import GHC.Types.SrcLoc (Located)+#endif++#if __GLASGOW_HASKELL__ < 902+type LocatedA = Located+type LocatedN = Located+#endif++data ParsedDecl+  = FuncSig [LocatedN RdrName] (LHsSigWcType GhcPs)+  | FuncDef (LocatedN RdrName) [LocatedA FuncSingleDef]++data FuncSingleDef = FuncSingleDef+  { funcDefArgs :: [LPat GhcPs]+  , funcDefGuards :: [FuncGuardedBody]+  , funcDefWhereClause :: HsLocalBinds GhcPs+  }++data FuncGuardedBody = FuncGuardedBody+  { funcDefBodyGuards :: [GuardLStmt GhcPs]+  , funcDefBody :: LHsExpr GhcPs+  }++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

@@ -0,0 +1,140 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Tasty.AutoCollect.GenerateMain (+  generateMainModule,+) where++import Data.List (sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath (makeRelative, splitExtensions, takeDirectory, (</>))++import Test.Tasty.AutoCollect.Config+import Test.Tasty.AutoCollect.Constants+import Test.Tasty.AutoCollect.Error+import Test.Tasty.AutoCollect.ModuleType+import Test.Tasty.AutoCollect.Utils.Text+import qualified Test.Tasty.AutoCollect.Utils.TreeMap as TreeMap++generateMainModule :: AutoCollectConfig -> FilePath -> IO Text+generateMainModule cfg@AutoCollectConfig{..} path = do+  testModules <- sortOn displayName <$> findTestModules cfg path+  pure . Text.unlines $+    [ "{-# OPTIONS_GHC -w #-}"+    , ""+    , "module Main (main) where"+    , ""+    , "import Test.Tasty"+    , Text.unlines . map ("import qualified " <>) $ map moduleName testModules ++ ingredientsModules+    , ""+    , "main :: IO ()"+    , "main = defaultMainWithIngredients ingredients (testGroup suiteName tests)"+    , "  where"+    , "    ingredients = " <> ingredients+    , "    suiteName = " <> suiteName+    , "    tests = " <> generateTests cfg testModules+    ]+  where+    ingredients =+      Text.unwords+        [ listify cfgIngredients+        , "++"+        , if cfgIngredientsOverride then "[]" else "defaultIngredients"+        ]++    ingredientsModules =+      flip map cfgIngredients $ \ingredient ->+        case fst $ Text.breakOnEnd "." ingredient of+          "" -> autocollectError $ "Ingredient needs to be fully qualified: " <> Text.unpack ingredient+          -- remove trailing "."+          s -> Text.init s++    suiteName = quoted $ fromMaybe (Text.pack path) cfgSuiteName++data TestModule = TestModule+  { moduleName :: Text+  -- ^ e.g. "My.Module.Test1"+  , displayName :: Text+  -- ^ The module name to display+  }++{- |+Find all test modules using the given path to the Main module.++>>> findTestModules "test/Main.hs"+["My.Module.Test1", "My.Module.Test2", ...]+-}+findTestModules :: AutoCollectConfig -> FilePath -> IO [TestModule]+findTestModules cfg path = listDirectoryRecursive testDir >>= mapMaybeM toTestModule+  where+    testDir = takeDirectory path++    toTestModule fp = do+      fileContents <- Text.readFile fp+      return $+        case (splitExtensions fp, parseModuleType fileContents) of+          ((fpNoExt, ".hs"), Just ModuleTest) ->+            let moduleName = Text.replace "/" "." . Text.pack . makeRelative testDir $ fpNoExt+             in Just+                  TestModule+                    { moduleName+                    , displayName = withoutSuffix (cfgStripSuffix cfg) moduleName+                    }+          _ -> Nothing++    mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]+    mapMaybeM f = fmap catMaybes . mapM f++generateTests :: AutoCollectConfig -> [TestModule] -> Text+generateTests AutoCollectConfig{..} testModules =+  case cfgGroupType of+    AutoCollectGroupFlat ->+      -- concat+      --   [ My.Module.Test1.tests+      --   , My.Module.Test2.tests+      --   , ...+      --   ]+      "concat " <> listify (map (addTestList . moduleName) testModules)+    AutoCollectGroupModules ->+      -- [ testGroup "My.Module.Test1" My.Module.Test1.tests+      -- , testGroup "My.Module.Test2" My.Module.Test2.tests+      -- ]+      listify . flip map testModules $ \TestModule{..} ->+        Text.unwords ["testGroup", quoted displayName, addTestList moduleName]+    AutoCollectGroupTree ->+      -- [ testGroup "My"+      --     [ testGroup "Module"+      --         [ testGroup "Test1" My.Module.Test1.tests+      --         , testGroup "Test2" My.Module.Test2.tests+      --         ]+      --     ]+      -- ]+      let getInfo TestModule{..} = (Text.splitOn "." displayName, addTestList moduleName)+       in TreeMap.foldTreeMap testGroupFromTree . TreeMap.fromList . map getInfo $ testModules+  where+    addTestList moduleName = moduleName <> "." <> Text.pack testListIdentifier+    testGroupFromTree mTestsIdentifier subTrees =+      let subGroups =+            flip map (Map.toAscList subTrees) $ \(testModuleDisplay, subTests) ->+              Text.unwords ["testGroup", quoted testModuleDisplay, "$", subTests]+       in case (subGroups, mTestsIdentifier) of+            (subGroups', Nothing) -> listify subGroups'+            ([], Just testsIdentifier) -> testsIdentifier+            (subGroups', Just testsIdentifier) -> "concat " <> listify [testsIdentifier, listify subGroups']++{----- Helpers -----}++listDirectoryRecursive :: FilePath -> IO [FilePath]+listDirectoryRecursive fp = fmap concat . mapM (go . (fp </>)) =<< listDirectory fp+  where+    go child = do+      isDir <- doesDirectoryExist child+      if isDir+        then listDirectoryRecursive child+        else pure [child]

@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Tasty.AutoCollect.ModuleType (+  ModuleType (..),+  parseModuleType,+) where++import Data.Char (isSpace)+import Data.Text (Text)+import qualified Data.Text as Text++import Test.Tasty.AutoCollect.Config+import Test.Tasty.AutoCollect.Constants++data ModuleType+  = ModuleMain AutoCollectConfig+  | ModuleTest+  deriving (Show, Eq)++parseModuleType :: Text -> Maybe ModuleType+parseModuleType = go . groupWhitespace+  where+    go [] = Nothing+    go ("{-" : _ : x : rest)+      | isMainComment (Text.unpack x) =+          case parseConfig $ Text.concat $ takeWhile (/= "-}") rest of+            Right cfg -> Just (ModuleMain cfg)+            Left e -> errorWithoutStackTrace $ "Could not parse configuration: " <> Text.unpack e+      | isTestComment (Text.unpack x) = Just ModuleTest+    go (_ : rest) = go rest++{- |+Group consecutive whitespace characters.++>>> groupWhitespace " a  bb  c "+[" ", "a", "  ", "bb", "  ", "c", " "]+-}+groupWhitespace :: Text -> [Text]+groupWhitespace = Text.groupBy (\c1 c2 -> isSpace c1 == isSpace c2)

@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Tasty.AutoCollect.Utils.Text (+  withoutPrefix,+  withoutSuffix,+  listify,+  quoted,+) where++import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text++withoutPrefix :: Text -> Text -> Text+withoutPrefix pre s = fromMaybe s $ Text.stripPrefix pre s++withoutSuffix :: Text -> Text -> Text+withoutSuffix post s = fromMaybe s $ Text.stripSuffix post s++-- | Convert a list @["a", "b"]@ to the text @"[\"a\", \"b\"]"@.+listify :: [Text] -> Text+listify xs = "[" <> Text.intercalate ", " xs <> "]"++quoted :: Text -> Text+quoted s = "\"" <> s <> "\""

@@ -0,0 +1,79 @@+{-# LANGUAGE RecordWildCards #-}++module Test.Tasty.AutoCollect.Utils.TreeMap (+  TreeMap (..),+  fromList,+  foldTreeMap,+) where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)++data TreeMap k v = TreeMap+  { value :: Maybe v+  , children :: Map k (TreeMap k v)+  }+  deriving (Show, Eq)++{- |+Convert the given list of values into a 'TreeMap'.++For example,+@+fromList [[A, B, C], [A, B], [A, C, D], [Z]]+@+would become+@+TreeMap+  { value = Nothing+  , children = Map.fromList+      [ ("A", TreeMap+          { value = Nothing+          , children = Map.fromList+              [ ("B", TreeMap+                  { value = Just ...+                  , children = Map.fromList+                      ("C", [ TreeMap+                          { value = Just ...+                          , children = Map.empty+                          }+                      ])+                  })+              , ("C", TreeMap+                  { value = Nothing+                  , children = Map.fromList+                      [ ("D", TreeMap+                          { value = Just ...+                          , children = Map.empty+                          })+                      ]+                  })+              ]+          })+    , ("Z", TreeMap+        { value = Just ...+        , children = Map.empty+        })+    ]+  }+@+-}+fromList :: Ord k => [([k], v)] -> TreeMap k v+fromList = foldr (uncurry insert) empty++empty :: TreeMap k v+empty = TreeMap Nothing Map.empty++insert :: Ord k => [k] -> v -> TreeMap k v -> TreeMap k v+insert originalKeys v = go originalKeys+  where+    go ks treeMap =+      case ks of+        [] -> treeMap{value = Just v}+        k : ks' -> treeMap{children = Map.alter (Just . go ks' . fromMaybe empty) k (children treeMap)}++foldTreeMap :: (Maybe v -> Map k r -> r) -> TreeMap k v -> r+foldTreeMap f = go+  where+    go TreeMap{..} = f value (go <$> children)

@@ -0,0 +1,50 @@+{-# LANGUAGE TypeApplications #-}++module Test.Tasty.Ext.Todo (+  testTreeTodo,+) where++import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)+import Test.Tasty.Options (+  IsOption (..),+  OptionDescription (..),+  flagCLParser,+  lookupOption,+  safeReadBool,+ )+import Test.Tasty.Providers (+  IsTest (..),+  TestName,+  testFailed,+  testPassed,+ )+import Test.Tasty.Runners (Result (..), TestTree (..))++data TodoTest = TodoTest+  deriving (Typeable)++instance IsTest TodoTest where+  run opts _ _ = pure testResult{resultShortDescription = "TODO"}+    where+      FailTodos shouldFail = lookupOption opts+      testResult =+        if shouldFail+          then testFailed "Failing because --fail-todos was set"+          else testPassed ""++  testOptions = pure [Option (Proxy @FailTodos)]++newtype FailTodos = FailTodos Bool+  deriving (Typeable)++instance IsOption FailTodos where+  defaultValue = FailTodos False+  parseValue = fmap FailTodos . safeReadBool+  optionName = pure "fail-todos"+  optionHelp = pure "Make TODO tests fail instead of succeeding"+  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

@@ -0,0 +1,134 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           tasty-autocollect+version:        0.1.0.0+synopsis:       Autocollection of tasty tests.+description:    Autocollection of tasty tests. See README.md for more details.+category:       Testing+homepage:       https://github.com/brandonchinn178/tasty-autocollect#readme+bug-reports:    https://github.com/brandonchinn178/tasty-autocollect/issues+author:         Brandon Chinn <brandonchinn178@gmail.com>+maintainer:     Brandon Chinn <brandonchinn178@gmail.com>+license:        BSD3+license-file:   LICENSE.md+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md+    test/golden/example.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_batch_args.golden+    test/golden/test_batch_type.golden++source-repository head+  type: git+  location: https://github.com/brandonchinn178/tasty-autocollect++library+  exposed-modules:+      Test.Tasty.AutoCollect+      Test.Tasty.AutoCollect.Config+      Test.Tasty.AutoCollect.Constants+      Test.Tasty.AutoCollect.ConvertTest+      Test.Tasty.AutoCollect.Error+      Test.Tasty.AutoCollect.ExternalNames+      Test.Tasty.AutoCollect.GenerateMain+      Test.Tasty.AutoCollect.ModuleType+      Test.Tasty.AutoCollect.Utils.Text+      Test.Tasty.AutoCollect.Utils.TreeMap+      Test.Tasty.Ext.Todo+  other-modules:+      Test.Tasty.AutoCollect.GHC+      Test.Tasty.AutoCollect.GHC.Shim+      Test.Tasty.AutoCollect.GHC.Shim_Common+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.14 && <5+    , containers >=0.6.4.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+    , transformers >=0.5.6.2 && <1+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances+  if impl(ghc < 8.8)+    ghc-options: -Wnoncanonical-monadfail-instances+  if impl(ghc >= 9.2) && impl(ghc < 9.4)+    other-modules:+        Test.Tasty.AutoCollect.GHC.Shim_9_2+  if impl(ghc >= 9.0) && impl(ghc < 9.2)+    other-modules:+        Test.Tasty.AutoCollect.GHC.Shim_9_0+  if impl(ghc >= 8.10) && impl(ghc < 9.0)+    other-modules:+        Test.Tasty.AutoCollect.GHC.Shim_8_10+  default-language: Haskell2010++executable tasty-autocollect+  main-is: Preprocessor.hs+  other-modules:+      Paths_tasty_autocollect+  hs-source-dirs:+      exe+  ghc-options: -Wall+  build-depends:+      base >=4.14 && <5+    , tasty-autocollect+    , text >=1.2.4.1 && <3+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances+  if impl(ghc < 8.8)+    ghc-options: -Wnoncanonical-monadfail-instances+  default-language: Haskell2010++test-suite tasty-autocollect-tests+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Examples+      Test.Tasty.AutoCollect.ConfigTest+      Test.Tasty.AutoCollect.ConvertTestTest+      Test.Tasty.AutoCollect.GenerateMainTest+      Test.Tasty.AutoCollect.ModuleTypeTest+      Test.Tasty.AutoCollect.Utils.TreeMapTest+      Test.Tasty.Ext.TodoTest+      TestUtils.Golden+      TestUtils.Integration+      TestUtils.Predicates+      TestUtils.QuickCheck+      Paths_tasty_autocollect+  hs-source-dirs:+      test+  ghc-options: -Wall -F -pgmF=tasty-autocollect+  build-depends:+      base+    , bytestring+    , containers+    , directory+    , explainable-predicates+    , filepath+    , tasty+    , tasty-autocollect+    , tasty-golden+    , tasty-hunit+    , tasty-quickcheck+    , temporary+    , text+    , typed-process+  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances+  if impl(ghc < 8.8)+    ghc-options: -Wnoncanonical-monadfail-instances+  default-language: Haskell2010+  build-tool-depends: tasty-autocollect:tasty-autocollect

@@ -0,0 +1,25 @@+{- AUTOCOLLECT.TEST -}+{-# LANGUAGE OverloadedStrings #-}++module Examples (+  -- $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 :: Assertion+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_goldenVsString :: IO ByteString+test_goldenVsString "Example golden test" "test/golden/example.golden" = pure "example"

@@ -0,0 +1,5 @@+{-+AUTOCOLLECT.MAIN+suite_name = tasty-autocollect+strip_suffix = Test+-}

@@ -0,0 +1,212 @@+{- AUTOCOLLECT.TEST -}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Tasty.AutoCollect.ConfigTest (+  -- $AUTOCOLLECT.TEST.export$+) where++import Data.Bifunctor (first)+import Data.Char (isSpace)+import Data.Text (Text)+import qualified Data.Text as Text+import Test.Predicates+import Test.Predicates.HUnit+import Test.Predicates.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Test.Tasty.AutoCollect.Config+import TestUtils.QuickCheck++{----- Configuration syntax -----}++test_testCase :: Assertion+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_testProperty :: Property+test_testProperty "parseConfig errors on ill-formed lines" =+  forAll (invalidLine `suchThat` (not . isIgnored)) $ \line ->+    parseConfig line `satisfies` left (startsWith "Invalid configuration line:")+  where+    isIgnored line = Text.all isSpace line || ("#" `Text.isPrefixOf` line)+    linePart = do+      ConfigPiece s <- arbitrary+      spaces <- arbitrary+      pure $ wrapSpaces spaces s++    invalidLine =+      oneof+        [ -- no '=' at all+          linePart+        , -- '... ='+          (<> "=") <$> linePart+        , -- '= ...'+          ("=" <>) <$> linePart+        , -- multiple '=' signs+          do+            Positive n <- arbitrary+            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)+  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_testProperty :: Property+test_testProperty "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:")++groupTypeOptions :: [(Text, AutoCollectGroupType)]+groupTypeOptions =+  [ ("flat", AutoCollectGroupFlat)+  , ("modules", AutoCollectGroupModules)+  , ("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_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_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_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_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_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:")+  where+    validKeys =+      [ "suite_name"+      , "group_type"+      , "ingredients"+      , "ingredients_override"+      , "strip_suffix"+      ]++{----- Helpers -----}++{- |+A Text suitable for use as a key or value in the configuration.++Specifically, will be a non-empty string that does not contain '=',+newlines, or trailing/leading spaces.+-}+newtype ConfigPiece = ConfigPiece {getConfigPiece :: Text}+  deriving (Show)++instance Arbitrary ConfigPiece where+  arbitrary =+    fmap ConfigPiece $+      (`suchThat` not . Text.null) $+        Text.strip . Text.filter (`notElem` ['=', '\n']) . getPrintableText <$> arbitrary++data Spaces = Spaces {before :: Int, after :: Int}+  deriving (Show)++wrapSpaces :: Spaces -> Text -> Text+wrapSpaces Spaces{..} s =+  Text.replicate before " " <> s <> Text.replicate after " "++instance Arbitrary Spaces where+  arbitrary = do+    Positive before <- arbitraryNumSpaces+    Positive after <- arbitraryNumSpaces+    pure $ Spaces before after+    where+      arbitraryNumSpaces =+        frequency+          [ (10, pure $ Positive 0)+          , (1, arbitrary)+          ]++-- | An arbitrary Haskell identifier+newtype HsIdentifier = HsIdentifier {getHsIdentifier :: Text}+  deriving (Show)++instance Arbitrary HsIdentifier where+  arbitrary = do+    modules <-+      frequency+        [ (5, pure [])+        , (1, listOf (identStartingWith large))+        ]+    ident <- identStartingWith small+    pure $ HsIdentifier $ Text.intercalate "." $ modules ++ [ident]+    where+      small = ['a' .. 'z']+      large = ['A' .. 'Z']+      digit = ['0' .. '9']++      identStartingWith start = do+        c <- elements start+        cs <- listOf $ elements (small ++ large ++ digit)+        pure $ Text.pack (c : cs)++data BoolOption = BoolOption {getBool :: Bool, getText :: Text}+  deriving (Show)++instance Arbitrary BoolOption where+  arbitrary = do+    b <- arbitrary+    s <- genMixedCase (Text.pack $ show b)+    pure $ BoolOption b s

@@ -0,0 +1,264 @@+{- 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.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)++import TestUtils.Golden+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"+      ]+  where+    isTastyImport line =+      case Text.unpack <$> Text.stripPrefix "import Test.Tasty" line of+        -- not an import / import from non-tasty library+        Nothing -> False+        -- import from `Test.Tasty`+        Just "" -> True+        -- import from `Test.Tasty (...)` or `Test.Tasty hiding (...)`+        Just " " -> True+        -- import from `Test.Tasty.Foo` or `Test.TastyFoo`, which is ok+        _ -> False++test_batch :: [TestTree]+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"+        ]+  | ext <-+      [ Just "-XOverloadedStrings"+      , Just "-XOverloadedLists"+      , Nothing+      ]+  ]+  where+    mkLabel = \case+      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+      ]+  | (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+        ]+  ]+  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__+  ]++test_testCase :: Assertion+test_testCase "test body can use definitions in where clause" = do+  (stdout, _) <-+    assertSuccess . runTest $+      [ "test_testCase :: Assertion"+      , "test_testCase \"a test\" = constant @?= 42"+      , "  where"+      , "    constant = 42"+      ]+  getTestLines stdout @?~ containsStripped (eq "a test: OK")++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"+      , ""+      , "constant :: Int"+      , "constant = 42"+      ]+  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")++test_testCase :: Assertion+test_testCase "test can be defined with arbitrary testers in where clause" = do+  (stdout, _) <-+    assertSuccess . runTest $+      [ "test_boolTestCase :: Bool"+      , "test_boolTestCase \"this is a successful test\" = 10 > 2"+      , "  where"+      , "    boolTestCase :: TestName -> Bool -> TestTree"+      , "    boolTestCase name x = testCase name $ assertBool \"assertion failed\" x"+      ]+  getTestLines stdout @?~ containsStripped (eq "this is a successful 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)+      ]+    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+  (_, stderr) <-+    assertAnyFailure . runTestWith (modifyFile "Test.hs" (map removeExports)) $+      [ "test_testCase :: Assertion"+      , "test_testCase \"a test\" = return ()"+      ]+  getTestLines stderr @?~ containsStripped (startsWith "Module ‘Test’ does not export")+  where+    removeExports s+      | "module " `Text.isPrefixOf` s = "module Test () where"+      | otherwise = s++test_testCase :: Assertion+test_testCase "test file can omit an explicit export list" = do+  (stdout, _) <-+    assertSuccess . runTestWith (modifyFile "Test.hs" (map removeExports)) $+      [ "test_testCase :: Assertion"+      , "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 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_testCase :: Assertion+test_testCase "test_batch generates multiple tests" = do+  (stdout, _) <-+    assertSuccess . runTest $+      [ "test_batch :: [TestTree]"+      , "test_batch ="+      , "  [ testCase (\"test #\" ++ show x) $ return ()"+      , "  | x <- [1 .. 5]"+      , "  ]"+      ]+  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+  (stdout, _) <-+    assertSuccess . runTest $+      [ "test_batch :: [TestTree]"+      , "test_batch ="+      , "  [ testCase (label x) $ return ()"+      , "  | x <- [1 .. 5]"+      , "  ]"+      , "  where"+      , "    label x = \"test #\" ++ show x"+      ]+  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+  (_, stderr) <-+    assertAnyFailure . runTest $+      [ "test_batch :: [TestTree]"+      , "test_batch \"some name\" = []"+      ]+  return stderr++test_testGolden :: IO Text+test_testGolden "test_batch fails when specifying wrong type" "test_batch_type.golden" = do+  (_, stderr) <-+    assertAnyFailure . runTest $+      [ "test_batch :: Int"+      , "test_batch = []"+      ]+  return stderr

@@ -0,0 +1,271 @@+{- AUTOCOLLECT.TEST -}+{-# LANGUAGE OverloadedStrings #-}++module Test.Tasty.AutoCollect.GenerateMainTest (+  -- $AUTOCOLLECT.TEST.export$+) where++import Data.Text (Text)+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 :: Assertion+test_testCase "searches recursively" = do+  (stdout, _) <-+    assertSuccess . runMainWith (addFiles [("A/B/C/X/Y/Z.hs", testFile)]) $+      [ "{- AUTOCOLLECT.MAIN"+      , "group_type = modules"+      , "-}"+      ]+  getTestLines stdout @?~ containsStripped (eq "A.B.C.X.Y.Z")+  where+    testFile =+      [ "{- AUTOCOLLECT.TEST -}"+      , "module A.B.C.X.Y.Z where"+      , "import Test.Tasty.HUnit"+      , "test_testCase :: Assertion"+      , "test_testCase \"test\" = return ()"+      ]++test_batch :: [TestTree]+test_batch =+  [ testGolden+    ("output for group_type = " <> groupType <> " is as expected")+    ("output_group_type_" <> groupType <> ".golden")+    $ fmap (normalizeTestOutput . fst) . assertSuccess . runMainWith (setTestFiles testFiles)+    $ [ "{- AUTOCOLLECT.MAIN"+      , "group_type = " <> Text.pack groupType+      , "-}"+      ]+  | groupType <- ["flat", "modules", "tree"]+  ]+  where+    testFiles =+      [ ("MyProject/Test/A.hs", testFile "MyProject.Test.A" "A")+      , ("MyProject/Test/A/X.hs", testFile "MyProject.Test.A.X" "AX")+      , ("MyProject/Test/A/Y.hs", testFile "MyProject.Test.A.Y" "AY")+      , ("MyProject/Test/A/Z.hs", testFile "MyProject.Test.A.Z" "AZ")+      , ("MyProject/Test/B.hs", testFile "MyProject.Test.B" "B")+      , ("MyProject/Test/C/A.hs", testFile "MyProject.Test.C.A" "CA")+      , ("MyProject/Test/C/B.hs", testFile "MyProject.Test.C.B" "CB")+      ]+    testFile moduleName ident =+      [ "{- 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_batch "Golden test on stdout of generateMain for each group type" = ()++test_testCase :: Assertion+test_testCase "generateMain orders test modules alphabetically" = do+  (stdout, _) <-+    assertSuccess . runMainWith (setTestFiles testFiles) $+      [ "{- AUTOCOLLECT.MAIN"+      , "group_type = modules"+      , "-}"+      ]+  getTestLines stdout+    @?~ startsWith+      [ "Main.hs"+      , "  A"+      , "    test: OK"+      , "  A.A"+      , "    test: OK"+      , "  A.B"+      , "    test: OK"+      , "  B"+      , "    test: OK"+      , "  C"+      , "    test: OK"+      ]+  where+    testFiles =+      [ ("A.hs", testFile "A")+      , ("A/A.hs", testFile "A.A")+      , ("A/B.hs", testFile "A.B")+      , ("B.hs", testFile "B")+      , ("C.hs", testFile "C")+      ]+    testFile moduleName =+      [ "{- AUTOCOLLECT.TEST -}"+      , "module " <> moduleName <> " where"+      , "import Test.Tasty.HUnit"+      , "test_testCase :: Assertion"+      , "test_testCase \"test\" = return ()"+      ]++test_testCase :: Assertion+test_testCase "allows stripping suffix from test modules" = do+  (stdout, _) <-+    assertSuccess . runMainWith (setTestFiles testFiles) $+      [ "{- AUTOCOLLECT.MAIN"+      , "group_type = modules"+      , "strip_suffix = Foo"+      , "-}"+      ]+  getTestLines stdout+    @?~ startsWith+      [ "Main.hs"+      , "  Tests.A"+      , "    test: OK"+      , "  Tests.B"+      , "    test: OK"+      ]+  where+    testFiles =+      [ ("Tests/AFoo.hs", testFile "Tests.AFoo")+      , ("Tests/BFoo.hs", testFile "Tests.BFoo")+      ]+    testFile moduleName =+      [ "{- AUTOCOLLECT.TEST -}"+      , "module " <> moduleName <> " where"+      , "import Test.Tasty.HUnit"+      , "test_testCase :: Assertion"+      , "test_testCase \"test\" = return ()"+      ]++test_testCase :: Assertion+test_testCase "suffix is stripped before building module tree" = do+  (stdout, _) <-+    assertSuccess . runMainWith (setTestFiles testFiles) $+      [ "{- AUTOCOLLECT.MAIN"+      , "group_type = tree"+      , "strip_suffix = Test"+      , "-}"+      ]+  getTestLines stdout+    @?~ startsWith+      [ "Main.hs"+      , "  A"+      , "    B"+      , "      C"+      , "        test1:   OK" -- should be under the same "C" as the "C.DTest" test module+      , "        D"+      , "          test2: OK"+      ]+  where+    testFiles =+      [+        ( "A/B/CTest.hs"+        ,+          [ "{- AUTOCOLLECT.TEST -}"+          , "module A.B.CTest where"+          , "import Test.Tasty.HUnit"+          , "test_testCase :: Assertion"+          , "test_testCase \"test1\" = return ()"+          ]+        )+      ,+        ( "A/B/C/DTest.hs"+        ,+          [ "{- AUTOCOLLECT.TEST -}"+          , "module A.B.C.DTest where"+          , "import Test.Tasty.HUnit"+          , "test_testCase :: Assertion"+          , "test_testCase \"test2\" = return ()"+          ]+        )+      ]++test_testCase :: Assertion+test_testCase "allows adding extra ingredients" = do+  (stdout, _) <-+    assertSuccess . runMainWith (addFiles [("MyIngredient.hs", ingredientFile)]) $+      [ "{- AUTOCOLLECT.MAIN"+      , "ingredients = MyIngredient.sayHelloAndExit"+      , "-}"+      ]+  stdout @?= "Hello!\n"+  where+    ingredientFile =+      [ "module MyIngredient where"+      , "import Test.Tasty.Ingredients"+      , "sayHelloAndExit :: Ingredient"+      , "sayHelloAndExit = TestManager [] $ \\_ _ -> Just $"+      , "  putStrLn \"Hello!\" >> return True"+      ]++test_testCase :: Assertion+test_testCase "gives informative error when ingredient lacks module" = do+  (_, stderr) <-+    assertAnyFailure . runMain $+      [ "{- AUTOCOLLECT.MAIN"+      , "ingredients = myIngredient"+      , "-}"+      ]+  getTestLines stderr @?~ contains (eq "Ingredient needs to be fully qualified: myIngredient")++test_testCase :: Assertion+test_testCase "allows disabling default tasty ingredients" = do+  (_, stderr) <-+    assertAnyFailure . runMain $+      [ "{- AUTOCOLLECT.MAIN"+      , "ingredients_override = true"+      , "-}"+      ]+  stderr @?~ startsWith "No ingredients agreed to run."++test_testCase :: Assertion+test_testCase "allows overriding suite name" = do+  (stdout, _) <-+    assertSuccess . runMain $+      [ "{- AUTOCOLLECT.MAIN"+      , "suite_name = my-test-suite"+      , "-}"+      ]+  stdout @?~ startsWith "my-test-suite"++{----- Helpers -----}++setTestFiles :: [(FilePath, FileContents)] -> GHCProject -> GHCProject+setTestFiles testFiles proj =+  proj+    { files = filter ((== "Main.hs") . fst) (files proj) ++ testFiles+    }++runMain :: FileContents -> IO (ExitCode, Text, Text)+runMain = runMainWith id++runMainWith :: (GHCProject -> GHCProject) -> FileContents -> IO (ExitCode, Text, Text)+runMainWith f mainFile =+  runghc . f $+    GHCProject+      { dependencies = ["tasty", "tasty-hunit"]+      , extraGhcArgs = ["-F", "-pgmF=tasty-autocollect"]+      , files =+          [ ("Main.hs", mainFile)+          , testFile "FooTest"+          , testFile "BarTest"+          ]+      , entrypoint = "Main.hs"+      , runArgs = []+      }+  where+    testFile moduleName =+      ( Text.unpack moduleName <> ".hs"+      ,+        [ "{- AUTOCOLLECT.TEST -}"+        , "module " <> moduleName <> " ({- AUTOCOLLECT.TEST.export -}) where"+        , "import Test.Tasty"+        , "import Test.Tasty.HUnit"+        , ""+        , "test_testCase :: Assertion"+        , "test_testCase \"a test in " <> moduleName <> "\" = return ()"+        ]+      )

@@ -0,0 +1,43 @@+{- AUTOCOLLECT.TEST -}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Test.Tasty.AutoCollect.ModuleTypeTest (+  -- $AUTOCOLLECT.TEST.export$+) where++import qualified Data.Text as Text+import Test.Predicates+import Test.Predicates.HUnit+import Test.Predicates.QuickCheck+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Test.Tasty.AutoCollect.Config+import Test.Tasty.AutoCollect.ModuleType+import TestUtils.QuickCheck++test_testCase :: Assertion+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" =+  forAll (genMixedCase "{- AUTOCOLLECT.MAIN -}") $ \main ->+    parseModuleType main `satisfies` just ($(qADT 'ModuleMain) anything)++test_testProperty :: Property+test_testProperty "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+  parseModuleType "{- AUTOCOLLECT.MAIN suite_name = foo -}"+    @?~ just ($(qADT 'ModuleMain) $ cfgSuiteName `with` eq (Just "foo"))+  parseModuleType "{- AUTOCOLLECT.MAIN\nsuite_name = foo\n-}"+    @?~ just ($(qADT 'ModuleMain) $ cfgSuiteName `with` eq (Just "foo"))

@@ -0,0 +1,32 @@+{- AUTOCOLLECT.TEST -}++module Test.Tasty.AutoCollect.Utils.TreeMapTest (+  -- $AUTOCOLLECT.TEST.export$+) where++import qualified Data.Map.Strict as Map+import Test.Tasty.HUnit++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) []+            ]+      }++child :: Ord k => k -> Maybe v -> [(k, TreeMap k v)] -> (k, TreeMap k v)+child k v sub = (k, TreeMap v (Map.fromList sub))

@@ -0,0 +1,43 @@+{- AUTOCOLLECT.TEST -}+{-# LANGUAGE OverloadedStrings #-}++module Test.Tasty.Ext.TodoTest (+  -- $AUTOCOLLECT.TEST.export$+) where++import Test.Predicates+import Test.Predicates.HUnit+import Test.Tasty.HUnit++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\" = ()"+        ]+  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 :: Assertion+test_testCase "TODO tests show compilation errors" = 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’")

@@ -0,0 +1,14 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module TestUtils.Golden (+  testGolden,+) where++import Data.Text (Text)+import qualified Data.Text.Lazy as TextL+import qualified Data.Text.Lazy.Encoding as TextL+import Test.Tasty (TestTree)+import Test.Tasty.Golden++testGolden :: String -> FilePath -> IO Text -> TestTree+testGolden name fp = goldenVsString name ("test/golden/" ++ fp) . fmap (TextL.encodeUtf8 . TextL.fromStrict)

@@ -0,0 +1,171 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module TestUtils.Integration (+  -- * Status assertions+  assertSuccess,+  assertSuccess_,+  assertAnyFailure,+  assertAnyFailure_,++  -- * GHCProject+  FileContents,+  GHCProject (..),+  addFiles,+  modifyFile,+  runghc,++  -- * Helpers+  runTest,+  runTestWith,+  getTestLines,+  normalizeTestOutput,++  -- * Re-exports+  ExitCode (..),+) where++import Control.Monad (forM_, void)+import Data.Char (isDigit)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Data.Text.Lazy as TextL+import qualified Data.Text.Lazy.Encoding as TextL+import System.Directory (createDirectoryIfMissing)+import System.FilePath (takeDirectory, (</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Process.Typed (ExitCode (..), proc, readProcess, setWorkingDir)++assertStatus :: (ExitCode -> Bool) -> IO (ExitCode, Text, Text) -> IO (Text, Text)+assertStatus isExpected testResult = do+  (code, stdout, stderr) <- testResult+  if isExpected code+    then return (stdout, stderr)+    else+      errorWithoutStackTrace . unlines $+        [ "Got: " ++ show code+        , "Stdout: " ++ Text.unpack stdout+        , "Stderr: " ++ Text.unpack stderr+        ]++assertSuccess :: IO (ExitCode, Text, Text) -> IO (Text, Text)+assertSuccess = assertStatus $ \case+  ExitSuccess -> True+  ExitFailure _ -> False++assertSuccess_ :: IO (ExitCode, Text, Text) -> IO ()+assertSuccess_ = void . assertSuccess++assertAnyFailure :: IO (ExitCode, Text, Text) -> IO (Text, Text)+assertAnyFailure = assertStatus $ \case+  ExitSuccess -> False+  ExitFailure _ -> True++assertAnyFailure_ :: IO (ExitCode, Text, Text) -> IO ()+assertAnyFailure_ = void . assertAnyFailure++{----- GHCProject -----}++-- | Contents of a file broken up by lines.+type FileContents = [Text]++data GHCProject = GHCProject+  { dependencies :: [Text]+  , extraGhcArgs :: [Text]+  , files :: [(FilePath, FileContents)]+  , entrypoint :: FilePath+  , runArgs :: [Text]+  }++addFiles :: [(FilePath, FileContents)] -> GHCProject -> GHCProject+addFiles newFiles proj = proj{files = files proj ++ newFiles}++modifyFile :: FilePath -> (FileContents -> FileContents) -> GHCProject -> GHCProject+modifyFile path f proj = proj{files = map modify (files proj)}+  where+    modify (fp, contents) = (fp, (if fp == path then f else id) contents)++-- | Compile and run the given project.+runghc :: GHCProject -> IO (ExitCode, Text, Text)+runghc GHCProject{..} =+  withSystemTempDirectory "tasty-autocollect-integration-test" $ \tmpdir -> do+    forM_ files $ \(fp, contents) -> do+      let testFile = tmpdir </> fp+      createDirectoryIfMissing True (takeDirectory testFile)+      Text.writeFile testFile (Text.unlines contents)++    let ghcArgs =+          concat+            [ ["-hide-all-packages"]+            , ["-package " <> dep | dep <- dependencies]+            , extraGhcArgs+            ]++    (code, stdout, stderr) <-+      readProcess $+        setWorkingDir tmpdir . proc "runghc" . concat $+          [ ["--"]+          , map Text.unpack ghcArgs+          , "--" : entrypoint : map Text.unpack runArgs+          ]++    let decode = TextL.toStrict . TextL.decodeUtf8+    return (code, decode stdout, decode stderr)++{----- Helpers -----}++{- |+Run a test file with tasty-autocollect.++Automatically imports Test.Tasty and Test.Tasty.HUnit.+-}+runTest :: FileContents -> IO (ExitCode, Text, Text)+runTest = runTestWith id++-- | Same as 'runTest', except allows modifying the project before running.+runTestWith :: (GHCProject -> GHCProject) -> FileContents -> IO (ExitCode, Text, Text)+runTestWith f contents =+  runghc . f $+    GHCProject+      { dependencies = ["tasty", "tasty-hunit"]+      , extraGhcArgs = ["-F", "-pgmF=tasty-autocollect"]+      , files =+          [ ("Test.hs", testFilePrefix ++ contents)+          , ("Main.hs", ["{- AUTOCOLLECT.MAIN -}"])+          ]+      , entrypoint = "Main.hs"+      , runArgs = []+      }+  where+    testFilePrefix =+      [ "{- AUTOCOLLECT.TEST -}"+      , "module Test ({- AUTOCOLLECT.TEST.export -}) where"+      , "import Test.Tasty"+      , "import Test.Tasty.HUnit"+      ]++-- | Get and normalize tasty output lines.+getTestLines :: Text -> [Text]+getTestLines = Text.lines . normalizeTestOutput++-- https://github.com/UnkindPartition/tasty/issues/341+normalizeTestOutput :: Text -> Text+normalizeTestOutput = Text.unlines . map normalize . Text.lines+  where+    normalize s+      | (pre, rest) <- breakOnEnd " (" s+      , Just inParens <- Text.stripSuffix ")" rest+      , Just (inParensNum, 's') <- Text.unsnoc inParens+      , [a, b] <- Text.splitOn "." inParensNum+      , Text.all isDigit a+      , Text.all isDigit b =+          pre+      | otherwise = s++    -- Text.breakOnEnd, but omits the delimiter+    breakOnEnd delim s =+      let (a, b) = Text.breakOnEnd delim s+       in (fromMaybe a (Text.stripSuffix delim a), b)

@@ -0,0 +1,34 @@+{-# LANGUAGE TemplateHaskell #-}++module TestUtils.Predicates (+  containsStripped,+) where++import Data.List (intercalate)+import Data.Text (Text)+import qualified Data.Text as Text+import Test.Predicates++{- |+A predicate for checking that the given lines of text+contain a line that, when stripped of whitespace, satisfies+the given predicate.++Writing our own because explainable-predicate's `contain`+function doesn't provide a good output on failure.+-}+containsStripped :: Predicate Text -> Predicate [Text]+containsStripped p =+  Predicate+    { showPredicate = "contains a stripped line matching: " ++ showPredicate p+    , showNegation = "does not contain a stripped line matching: " ++ showNegation p+    , accept = any (accept p . Text.strip)+    , explain = \xs ->+        case filter (accept p . Text.strip . snd) $ zip [1 ..] xs of+          [] -> "No lines match: " ++ showPredicate p ++ "\n" ++ show xs+          matched ->+            intercalate "\n" $+              [ "element #" ++ show (i :: Int) ++ ": " ++ explain p x+              | (i, x) <- matched+              ]+    }

@@ -0,0 +1,26 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module TestUtils.QuickCheck (+  PrintableText (..),+  genMixedCase,+) where++import Data.Char (toLower, toUpper)+import Data.String (IsString)+import Data.Text (Text)+import qualified Data.Text as Text+import Test.Tasty.QuickCheck++newtype PrintableText = PrintableText {getPrintableText :: Text}+  deriving (Show, IsString)++instance Arbitrary PrintableText where+  arbitrary = PrintableText . Text.pack . getPrintableString <$> arbitrary++genMixedCase :: Text -> Gen Text+genMixedCase s = withCases <$> infiniteList+  where+    withCases cases = Text.pack . zipWith setCase cases . Text.unpack $ s++    setCase False = toLower+    setCase True = toUpper

@@ -0,0 +1,1 @@+example

@@ -0,0 +1,17 @@+Main.hs+  test #1 for A:  OK+  test #2 for A:  OK+  test #1 for AX: OK+  test #2 for AX: OK+  test #1 for AY: OK+  test #2 for AY: OK+  test #1 for AZ: OK+  test #2 for AZ: OK+  test #1 for B:  OK+  test #2 for B:  OK+  test #1 for CA: OK+  test #2 for CA: OK+  test #1 for CB: OK+  test #2 for CB: OK++All 14 tests passed

@@ -0,0 +1,24 @@+Main.hs+  MyProject.Test.A+    test #1 for A:  OK+    test #2 for A:  OK+  MyProject.Test.A.X+    test #1 for AX: OK+    test #2 for AX: OK+  MyProject.Test.A.Y+    test #1 for AY: OK+    test #2 for AY: OK+  MyProject.Test.A.Z+    test #1 for AZ: OK+    test #2 for AZ: OK+  MyProject.Test.B+    test #1 for B:  OK+    test #2 for B:  OK+  MyProject.Test.C.A+    test #1 for CA: OK+    test #2 for CA: OK+  MyProject.Test.C.B+    test #1 for CB: OK+    test #2 for CB: OK++All 14 tests passed

@@ -0,0 +1,27 @@+Main.hs+  MyProject+    Test+      A+        test #1 for A:    OK+        test #2 for A:    OK+        X+          test #1 for AX: OK+          test #2 for AX: OK+        Y+          test #1 for AY: OK+          test #2 for AY: OK+        Z+          test #1 for AZ: OK+          test #2 for AZ: OK+      B+        test #1 for B:    OK+        test #2 for B:    OK+      C+        A+          test #1 for CA: OK+          test #2 for CA: OK+        B+          test #1 for CB: OK+          test #2 for CB: OK++All 14 tests passed

@@ -0,0 +1,4 @@++******************** tasty-autocollect failure ********************+test_batch should not be used with arguments+

@@ -0,0 +1,4 @@++******************** tasty-autocollect failure ********************+test_batch needs to be set to a [TestTree]+