tasty-autocollect 0.3.2.0 → 0.4.0

raw patch · 27 files changed

+654/−685 lines, 27 filesdep ~ghcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +102/−79
• exe/Preprocessor.hs +1/−1
• src/Test/Tasty/AutoCollect.hs +4/−1
• src/Test/Tasty/AutoCollect/Config.hs +104/−34
• src/Test/Tasty/AutoCollect/ConvertTest.hs +128/−103
• src/Test/Tasty/AutoCollect/ExternalNames.hs +1/−1
• src/Test/Tasty/AutoCollect/GHC.hs +5/−4
• src/Test/Tasty/AutoCollect/GHC/Shim.hs +1/−3
• src/Test/Tasty/AutoCollect/GHC/Shim_8_10.hs +0/−229
• src/Test/Tasty/AutoCollect/GHC/Shim_9_0.hs +5/−26
• src/Test/Tasty/AutoCollect/GHC/Shim_9_2.hs +12/−26
• src/Test/Tasty/AutoCollect/GHC/Shim_9_4.hs +5/−26
• src/Test/Tasty/AutoCollect/GenerateMain.hs +40/−16
• src/Test/Tasty/AutoCollect/ModuleType.hs +5/−7
• src/Test/Tasty/AutoCollect/Utils/TreeMap.hs +41/−43
• tasty-autocollect.cabal +5/−20
• test/Test/Tasty/AutoCollect/ConfigTest.hs +50/−12
• test/Test/Tasty/AutoCollect/ConvertTestTest.hs +31/−22
• test/Test/Tasty/AutoCollect/GenerateMainTest.hs +88/−9
• test/Test/Tasty/AutoCollect/ModuleTypeTest.hs +2/−2
• test/Test/Tasty/Ext/TodoTest.hs +3/−3
• test/TestUtils/Integration.hs +5/−7
• test/TestUtils/Predicates.hs +6/−8
• test/golden/test_args.golden +1/−1
• test/golden/test_batch_args.golden +1/−1
• test/golden/test_todo_args.golden +1/−1

@@ -1,3 +1,10 @@+# v0.4.0++* Drop support for GHC 8.10+* Added support for where clauses in `test_prop`, where the where clause may reference the generated arguments in `test_prop`+* Don't autocollect invalid module names+* Enable importing configuration from other files+ # v0.3.2.0  * Added support for GHC 9.4

@@ -1,6 +1,6 @@ # 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/github/actions/workflow/status/brandonchinn178/tasty-autocollect/ci.yml?branch=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) @@ -8,13 +8,12 @@  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 * Support arbitrary test functions (e.g. user-defined test helpers or third-party tasty libraries)--## Usage+* Minimal dependencies+  * Only uses boot libraries, with two exceptions: `tasty` + `tasty-expected-failure` -### Quickstart+## Quickstart  1. Add the following to your `package.yaml` or `.cabal` file: @@ -76,79 +75,11 @@      test =       testGroup "manually defining a test group"-        [ testCase "some test" $ return ()-        , testCase "some other test" $ return ()+        [ testCase "some test" $ pure ()+        , testCase "some other test" $ pure ()         ]     ``` -### 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 named `test`. It will then rename the function to `tasty_test_N`, where `N` is an autoincrementing, unique number. Then it will collect all the tests into a `tasty_tests :: [TestTree]` binding, which is exported at the location of the `{- AUTOCOLLECT.TEST.export -}` comment.--### Configuration--`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--* 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.@@ -189,7 +120,7 @@  ```hs test_batch =-  [ testCase ("test #" ++ show x) $ return ()+  [ testCase ("test #" ++ show x) $ pure ()   | x <- [1, 5, 10 :: Int]   ] ```@@ -197,11 +128,11 @@ is equivalent to writing:  ```hs-test = testCase "test #1" $ return ()+test = testCase "test #1" $ pure () -test = testCase "test #5" $ return ()+test = testCase "test #5" $ pure () -test = testCase "test #10" $ return ()+test = testCase "test #10" $ pure () ```  ### Integration with `tasty-expected-failures`@@ -239,6 +170,72 @@ test_prop_expectFailBecause "Issue #123" "some property" x = x === x ``` +## 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++# comments can start with a hash symbol+group_type = flat+-}+```++* `import`: A comma separated list of files (relative to the Main file) containing configuration to import+    * Recommended file extension: `.conf`+    * Configuration in files later in the list override configuration in files earlier in the list+    * Configuration in the Main file override imported configuration++* `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.++* `custom_main`: If you'd like fine-grained control over how the `Main` module is generated (e.g. if you're using `NoImplicitPrelude` or custom preludes), set this to `true`. When set, it will do the following replacements:+    * `{- AUTOCOLLECT.MAIN.imports -}`: replaced with the import lines needed for the tests.+    * `{- AUTOCOLLECT.MAIN.tests -}`: replaced with the `[TestTree]` list, all on one line. If you're using a formatter or linter, it might be helpful to do `tests = id {- AUTOCOLLECT.MAIN.tests -}` so that the code still parses.++    Due to current limitations, the above comments need to be matched exactly (e.g. not with `--` comments or extra whitespace).+ ## Comparison with `tasty-discover`  Advantages:@@ -255,3 +252,29 @@ 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++## Appendix++### Debugging ++To inspect the generated Main module, build with `-keep-tmp-files`, and look in `$TMPDIR` for a `ghc_1.hspp` file. (Upstream tickets: [GHC](https://gitlab.haskell.org/ghc/ghc/-/issues/22258), [Stack](https://github.com/commercialhaskell/stack/issues/5892))++To inspect the converted test modules, build with `-ddump-rn -ddump-to-file` and look for the `.dump-rn` files in `.stack-work/` or `dist-newstyle/`.++### Note for Ormolu/Fourmolu++If you're using Ormolu or Fourmolu, use `-- $AUTOCOLLECT.TEST.export$` instead; otherwise, the comment will be moved 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++### 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 named `test`. It will then rename the function to `tasty_test_N`, where `N` is an autoincrementing, unique number. Then it will collect all the tests into a `tasty_tests :: [TestTree]` binding, which is exported at the location of the `{- AUTOCOLLECT.TEST.export -}` comment.

@@ -1,6 +1,6 @@ {-# 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

@@ -7,6 +7,7 @@ import Data.Text (Text) import qualified Data.Text as Text +import Test.Tasty.AutoCollect.Config import Test.Tasty.AutoCollect.GenerateMain import Test.Tasty.AutoCollect.ModuleType import Test.Tasty.AutoCollect.Utils.Text@@ -15,7 +16,9 @@ processFile :: FilePath -> Text -> IO Text processFile path file =   case parseModuleType file of-    Just (ModuleMain cfg) -> addLinePragma <$> generateMainModule cfg path+    Just (ModuleMain cfg) -> do+      cfg' <- resolveConfig path cfg+      addLinePragma <$> generateMainModule cfg' path file     Just ModuleTest ->       pure         . addLine "{-# OPTIONS_GHC -fplugin=Test.Tasty.AutoCollect.ConvertTest #-}"

@@ -1,36 +1,63 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-}  module Test.Tasty.AutoCollect.Config (-  AutoCollectConfig (..),+  AutoCollectConfig' (..),+  AutoCollectConfig,+  AutoCollectConfigPartial,   AutoCollectGroupType (..),-  defaultConfig,   parseConfig,+  resolveConfig, ) where +import Control.Applicative ((<|>))+import Control.Monad (forM)+import Data.Functor.Identity (Identity)+import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import System.FilePath (takeDirectory, (</>))  {----- Configuration -----} +type family Apply f a where+  Apply Maybe a = Maybe a+  Apply Identity a = a+ -- | Configuration for generating the Main module, specified as a block comment.-data AutoCollectConfig = AutoCollectConfig-  { cfgSuiteName :: Maybe Text+data AutoCollectConfig' f = AutoCollectConfig+  { cfgImports :: Apply f [FilePath]+  -- ^ Files to import+  , cfgSuiteName :: Apply f (Maybe Text)   -- ^ The name of the entire test suite-  , cfgGroupType :: AutoCollectGroupType+  , cfgGroupType :: Apply f AutoCollectGroupType   -- ^ How tests should be grouped (defaults to "modules")-  , cfgStripSuffix :: Text+  , cfgStripSuffix :: Apply f Text   -- ^ The suffix to strip from a test, e.g. @strip_suffix = Test@ will relabel   -- a module @Foo.BarTest@ to @Foo.Bar@.-  , cfgIngredients :: [Text]+  , cfgIngredients :: Apply f [Text]   -- ^ A comma-separated list of extra tasty ingredients to include-  , cfgIngredientsOverride :: Bool+  , cfgIngredientsOverride :: Apply f Bool   -- ^ If true, 'cfgIngredients' overrides the default tasty ingredients;   -- otherwise, they're prepended to the list of default ingredients (defaults to false)+  , cfgCustomMain :: Apply f Bool   }-  deriving (Show, Eq) +type AutoCollectConfigPartial = AutoCollectConfig' Maybe+deriving instance Show AutoCollectConfigPartial+deriving instance Eq AutoCollectConfigPartial++type AutoCollectConfig = AutoCollectConfig' Identity+deriving instance Show AutoCollectConfig+deriving instance Eq AutoCollectConfig+ data AutoCollectGroupType   = -- | All tests will be flattened like     --@@ -63,22 +90,38 @@     AutoCollectGroupTree   deriving (Show, Eq) -defaultConfig :: AutoCollectConfig-defaultConfig =-  AutoCollectConfig-    { cfgSuiteName = Nothing-    , cfgGroupType = AutoCollectGroupModules-    , cfgIngredients = []-    , cfgIngredientsOverride = False-    , cfgStripSuffix = ""-    }+-- | Config on RHS overrides config on LHS.+instance Semigroup AutoCollectConfigPartial where+  cfg1 <> cfg2 =+    AutoCollectConfig+      { cfgImports = cfgImports cfg2 <|> cfgImports cfg1+      , cfgSuiteName = cfgSuiteName cfg2 <|> cfgSuiteName cfg1+      , cfgGroupType = cfgGroupType cfg2 <|> cfgGroupType cfg1+      , cfgIngredients = cfgIngredients cfg2 <|> cfgIngredients cfg1+      , cfgIngredientsOverride = cfgIngredientsOverride cfg2 <|> cfgIngredientsOverride cfg1+      , cfgStripSuffix = cfgStripSuffix cfg2 <|> cfgStripSuffix cfg1+      , cfgCustomMain = cfgCustomMain cfg2 <|> cfgCustomMain cfg1+      } -parseConfig :: Text -> Either Text AutoCollectConfig-parseConfig = fmap resolve . mapM parseLine . filter (not . isIgnoredLine) . Text.lines+instance Monoid AutoCollectConfigPartial where+  mempty =+    AutoCollectConfig+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing+      Nothing++{----- Parsing -----}++parseConfig :: Text -> Either Text AutoCollectConfigPartial+parseConfig = fmap mconcat . 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 :: Text -> Either Text AutoCollectConfigPartial     parseLine s = do       (k, v) <-         case Text.splitOn "=" s of@@ -89,23 +132,25 @@           _ -> Left $ "Invalid configuration line: " <> Text.pack (show s)        case k of+        "import" ->+          pure mempty{cfgImports = Just $ map Text.unpack $ parseCSV v}         "suite_name" ->-          pure $ \cfg -> cfg{cfgSuiteName = Just v}+          pure mempty{cfgSuiteName = Just (Just v)}         "group_type" -> do           groupType <- parseGroupType v-          pure $ \cfg -> cfg{cfgGroupType = groupType}+          pure mempty{cfgGroupType = Just groupType}         "strip_suffix" ->-          pure $ \cfg -> cfg{cfgStripSuffix = v}-        "ingredients" -> do-          let ingredients = map Text.strip . Text.splitOn "," $ v-          pure $ \cfg -> cfg{cfgIngredients = ingredients}+          pure mempty{cfgStripSuffix = Just v}+        "ingredients" ->+          pure mempty{cfgIngredients = Just $ parseCSV v}         "ingredients_override" -> do           override <- parseBool v-          pure $ \cfg -> cfg{cfgIngredientsOverride = override}+          pure mempty{cfgIngredientsOverride = Just override}+        "custom_main" -> do+          customMain <- parseBool v+          pure mempty{cfgCustomMain = Just customMain}         _ -> Left $ "Invalid configuration key: " <> Text.pack (show k) -    resolve fs = compose fs defaultConfig- parseGroupType :: Text -> Either Text AutoCollectGroupType parseGroupType = \case   "flat" -> pure AutoCollectGroupFlat@@ -113,6 +158,9 @@   "tree" -> pure AutoCollectGroupTree   ty -> Left $ "Invalid group_type: " <> Text.pack (show ty) +parseCSV :: Text -> [Text]+parseCSV = map Text.strip . Text.splitOn ","+ parseBool :: Text -> Either Text Bool parseBool s =   case Text.toLower s of@@ -120,8 +168,30 @@     "false" -> pure False     _ -> Left $ "Invalid bool: " <> Text.pack (show s) -{----- Utilities -----}+{----- Resolving -----} --- | [f, g, h] => (h . g . f)-compose :: [a -> a] -> a -> a-compose fs = foldr (\f acc -> acc . f) id fs+resolveConfig :: FilePath -> AutoCollectConfigPartial -> IO AutoCollectConfig+resolveConfig path0 cfg0 = resolve <$> resolveImports path0 cfg0+  where+    resolveImports path cfg = do+      let imports = fromMaybe [] $ cfgImports cfg+      fmap (mergeConfigs cfg) . forM imports $ \imp -> do+        let fp = takeDirectory path </> imp+        file <- Text.readFile fp+        case parseConfig file of+          Right cfg' -> resolveImports fp cfg'+          Left e -> errorWithoutStackTrace $ "Could not parse imported config (" <> fp <> "): " <> Text.unpack e++    mergeConfigs cfg importedCfgs = mconcat importedCfgs <> cfg++    resolve :: AutoCollectConfigPartial -> AutoCollectConfig+    resolve AutoCollectConfig{..} =+      AutoCollectConfig+        { cfgImports = []+        , cfgSuiteName = fromMaybe Nothing cfgSuiteName+        , cfgGroupType = fromMaybe AutoCollectGroupModules cfgGroupType+        , cfgIngredients = fromMaybe [] cfgIngredients+        , cfgIngredientsOverride = fromMaybe False cfgIngredientsOverride+        , cfgStripSuffix = fromMaybe "" cfgStripSuffix+        , cfgCustomMain = fromMaybe False cfgCustomMain+        }

@@ -36,41 +36,39 @@           pure $ withParsedResultModule result (transformTestModule names)       } -{- |-Transforms a test module of the form--@-{\- AUTOCOLLECT.TEST -\}-module MyTest (-  foo,-  {\- AUTOCOLLECT.TEST.export -\}-  bar,-) where--test = ...-@--to the equivalent of--@-module MyTest (-  foo,-  tasty_tests,-  bar,-) where--tasty_tests :: [TestTree]-tasty_tests = [tasty_test_1]--tasty_test_1 :: TestTree-tasty_test_1 = ...-@--}+-- | Transforms a test module of the form+--+-- @+-- {\- AUTOCOLLECT.TEST -\}+-- module MyTest (+--   foo,+--   {\- AUTOCOLLECT.TEST.export -\}+--   bar,+-- ) where+--+-- test = ...+-- @+--+-- to the equivalent of+--+-- @+-- module MyTest (+--   foo,+--   tasty_tests,+--   bar,+-- ) where+--+-- tasty_tests :: [TestTree]+-- tasty_tests = [tasty_test_1]+--+-- tasty_test_1 :: TestTree+-- tasty_test_1 = ...+-- @ transformTestModule :: ExternalNames -> HsParsedModule -> HsParsedModule transformTestModule names parsedModl = parsedModl{hpm_module = updateModule <$> hpm_module parsedModl}   where     updateModule modl =-      let (decls, testNames) = runConvertTestM $ concatMapM (convertTest names) $ hsmodDecls modl+      let (decls, testNames) = runConvertTestModuleM $ concatMapM (convertTest names) $ hsmodDecls modl        in modl             { hsmodExports = updateExports <$> hsmodExports modl             , hsmodDecls = mkTestsList testNames ++ decls@@ -101,11 +99,9 @@         mkExprTypeSig testsList . genLoc $           HsListTy noAnn (getListOfTestTreeType names) -{- |-If the given declaration is a test, return the converted test, or otherwise-return it unmodified--}-convertTest :: ExternalNames -> LHsDecl GhcPs -> ConvertTestM [LHsDecl GhcPs]+-- | If the given declaration is a test, return the converted test, or otherwise+-- return it unmodified+convertTest :: ExternalNames -> LHsDecl GhcPs -> ConvertTestModuleM [LHsDecl GhcPs] convertTest names ldecl =   case parseDecl ldecl of     Just (FuncSig [funcName] ty)@@ -142,9 +138,21 @@             | testType == testTypeFromSig -> pure (testName, Just signatureType)             | otherwise -> autocollectError $ "Found test with different type of signature: " ++ show (testType, testTypeFromSig) -      testBody <-+      (testBody, ConvertTestState{mWhereClause}) <-         case funcDefGuards of-          [FuncGuardedBody [] body] -> convertSingleTestBody testType mSigType funcDefArgs body+          [FuncGuardedBody [] body] -> do+            let state =+                  ConvertTestState+                    { mSigType+                    , testArgs = funcDefArgs+                    , mWhereClause = Just funcDefWhereClause+                    }+            pure . runConvertTestM state $ do+              testBody <- convertSingleTestBody testType body+              State.gets testArgs >>= \case+                [] -> pure ()+                _ -> autocollectError $ "Found extraneous arguments at " ++ getSpanLine loc+              pure testBody           _ ->             autocollectError . unlines $               [ "Test should have no guards."@@ -155,53 +163,57 @@         [ if isNothing mSigInfo             then [genLoc $ genFuncSig testName (getListOfTestTreeType names)]             else []-        , [genFuncDecl testName [] testBody (Just funcDefWhereClause) <$ ldecl]+        , [genFuncDecl testName [] testBody mWhereClause <$ ldecl]         ] -    convertSingleTestBody testType mSigType args body =+    convertSingleTestBody testType body =       case testType of-        TestNormal -> do-          checkNoArgs testType args+        TestNormal ->           pure $ singleExpr body         TestProp -> do+          -- test_prop :: <type>+          -- test_prop "name" arg1 arg2 = <body> where <defs>+          -- ====>+          -- test = testProperty "name" ((\arg1 arg2 -> let <defs> in <body>) :: <type>)++          state@ConvertTestState{mSigType, mWhereClause} <- State.get+          State.put state{mSigType = Nothing, mWhereClause = Nothing}+           (name, remainingPats) <--            case args of-              arg : rest | Just s <- parseLitStrPat arg -> return (s, rest)+            popRemainingArgs >>= \case+              arg : rest | Just s <- parseLitStrPat arg -> pure (s, rest)               [] -> autocollectError "test_prop requires at least the name of the test"               arg : _ ->                 autocollectError . unlines $                   [ "test_prop expected a String for the name of the test."                   , "Got: " ++ showPpr arg                   ]-          let propBody = mkHsLam remainingPats body++          let propBody =+                mkHsLam remainingPats $+                  case mWhereClause of+                    Just defs -> genLoc $ mkLet defs body+                    Nothing -> body+           pure . singleExpr $             mkHsApps               (lhsvar $ mkLRdrName "testProperty")               [ mkHsLitString name               , maybe propBody (genLoc . ExprWithTySig noAnn propBody) mSigType               ]-        TestTodo -> do-          checkNoArgs testType args+        TestTodo ->           pure . singleExpr $             mkHsApp               (mkHsVar $ name_testTreeTodo names)               (mkExprTypeSig body $ mkHsTyVar (name_String names))-        TestBatch -> do-          checkNoArgs testType args+        TestBatch ->           pure body         TestModify modifier testType' ->-          withTestModifier names modifier loc args $ \args' ->-            convertSingleTestBody testType' mSigType args' body+          withTestModifier names modifier loc $+            convertSingleTestBody testType' body      singleExpr = genLoc . mkExplicitList . (: []) -    checkNoArgs testType args =-      unless (null args) $-        autocollectError . unwords $-          [ showTestType testType ++ " should not be used with arguments"-          , "(at " ++ getSpanLine loc ++ ")"-          ]- -- | Identifier for the generated `tests` list. testListName :: LocatedN RdrName testListName = mkLRdrName testListIdentifier@@ -243,20 +255,6 @@      unsnoc = fmap (NonEmpty.init &&& NonEmpty.last) . NonEmpty.nonEmpty -showTestType :: TestType -> String-showTestType = \case-  TestNormal -> "test"-  TestProp -> "test_prop"-  TestTodo -> "test_todo"-  TestBatch -> "test_batch"-  TestModify modifier tt -> showTestType tt ++ showModifier modifier-  where-    showModifier = \case-      ExpectFail -> "_expectFail"-      ExpectFailBecause -> "_expectFailBecause"-      IgnoreTest -> "_ignoreTest"-      IgnoreTestBecause -> "_ignoreTestBecause"- isValidForTestType :: ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool isValidForTestType names = \case   TestNormal -> parsedTypeMatches isTestTreeTypeVar@@ -296,36 +294,34 @@   _ -> False  withTestModifier ::-  Monad m =>-  ExternalNames ->-  TestModifier ->-  SrcSpan ->-  [LPat GhcPs] ->-  ([LPat GhcPs] -> m (LHsExpr GhcPs)) ->-  m (LHsExpr GhcPs)-withTestModifier names modifier loc args f =+  ExternalNames+  -> TestModifier+  -> SrcSpan+  -> ConvertTestM (LHsExpr GhcPs)+  -> ConvertTestM (LHsExpr GhcPs)+withTestModifier names modifier loc m =   case modifier of-    ExpectFail -> mapAllTests (mkHsVar $ name_expectFail names) <$> f args+    ExpectFail -> mapAllTests (mkHsVar $ name_expectFail names) <$> m     ExpectFailBecause ->-      case args of-        arg : rest+      popArg >>= \case+        Just arg           | Just s <- parseLitStrPat arg ->-              mapAllTests (applyName (name_expectFailBecause names) [mkHsLitString s]) <$> f rest-        _ -> needsStrArg "_expectFailBecause"-    IgnoreTest -> mapAllTests (mkHsVar $ name_ignoreTest names) <$> f args+              mapAllTests (applyName (name_expectFailBecause names) [mkHsLitString s]) <$> m+        mArg -> needsStrArg mArg "_expectFailBecause"+    IgnoreTest -> mapAllTests (mkHsVar $ name_ignoreTest names) <$> m     IgnoreTestBecause ->-      case args of-        arg : rest+      popArg >>= \case+        Just arg           | Just s <- parseLitStrPat arg ->-              mapAllTests (applyName (name_ignoreTestBecause names) [mkHsLitString s]) <$> f rest-        _ -> needsStrArg "_ignoreTestBecause"+              mapAllTests (applyName (name_ignoreTestBecause names) [mkHsLitString s]) <$> m+        mArg -> needsStrArg mArg "_ignoreTestBecause"   where-    needsStrArg label =+    needsStrArg mArg label =       autocollectError . unlines . concat $         [ [label ++ " requires a String argument."]-        , case args of-            [] -> []-            arg : _ -> ["Got: " ++ showPpr arg]+        , case mArg of+            Nothing -> []+            Just arg -> ["Got: " ++ showPpr arg]         , ["At: " ++ getSpanLine loc]         ] @@ -334,11 +330,40 @@     -- mapAllTests f e = [| map $f $e |]     mapAllTests func expr = applyName (name_map names) [func, expr] -{----- Test converter monad -----}+{----- Test function converter monad -----}  type ConvertTestM = State ConvertTestState  data ConvertTestState = ConvertTestState+  { mSigType :: Maybe (LHsSigWcType GhcPs)+  , mWhereClause :: Maybe (HsLocalBinds GhcPs)+  , testArgs :: [LPat GhcPs]+  }++runConvertTestM :: ConvertTestState -> ConvertTestM a -> (a, ConvertTestState)+runConvertTestM = flip State.runState++popArg :: ConvertTestM (Maybe (LPat GhcPs))+popArg = do+  state <- State.get+  let (mArg, rest) =+        case testArgs state of+          [] -> (Nothing, [])+          arg : args -> (Just arg, args)+  State.put state{testArgs = rest}+  pure mArg++popRemainingArgs :: ConvertTestM [LPat GhcPs]+popRemainingArgs = do+  state@ConvertTestState{testArgs} <- State.get+  State.put state{testArgs = []}+  pure testArgs++{----- Test module converter monad -----}++type ConvertTestModuleM = State ConvertTestModuleState++data ConvertTestModuleState = ConvertTestModuleState   { lastSeenSig :: Maybe SigInfo   , allTests :: Seq (LocatedN RdrName)   }@@ -352,26 +377,26 @@   -- ^ The type captured in the signature   } -runConvertTestM :: ConvertTestM a -> (a, [LocatedN RdrName])-runConvertTestM m =+runConvertTestModuleM :: ConvertTestModuleM a -> (a, [LocatedN RdrName])+runConvertTestModuleM m =   fmap (toList . allTests) . State.runState m $-    ConvertTestState+    ConvertTestModuleState       { lastSeenSig = Nothing       , allTests = Seq.Empty       } -getLastSeenSig :: ConvertTestM (Maybe SigInfo)+getLastSeenSig :: ConvertTestModuleM (Maybe SigInfo) getLastSeenSig = do-  state@ConvertTestState{lastSeenSig} <- State.get+  state@ConvertTestModuleState{lastSeenSig} <- State.get   State.put state{lastSeenSig = Nothing}   pure lastSeenSig -setLastSeenSig :: SigInfo -> ConvertTestM ()+setLastSeenSig :: SigInfo -> ConvertTestModuleM () setLastSeenSig info = State.modify' $ \state -> state{lastSeenSig = Just info} -getNextTestName :: ConvertTestM (LocatedN RdrName)+getNextTestName :: ConvertTestModuleM (LocatedN RdrName) getNextTestName = do-  state@ConvertTestState{allTests} <- State.get+  state@ConvertTestModuleState{allTests} <- State.get   let nextTestName = mkLRdrName $ testIdentifier (length allTests)   State.put state{allTests = allTests Seq.|> nextTestName}   pure nextTestName

@@ -40,4 +40,4 @@   where     loadName name =       thNameToGhcNameIO env (hsc_NC env) name-        >>= maybe (autocollectError $ "Could not get Name for " ++ show name) return+        >>= maybe (autocollectError $ "Could not get Name for " ++ show name) pure

@@ -36,6 +36,7 @@ import Data.Foldable (foldl') import Data.List (sortOn) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import qualified GHC.Types.Name.Occurrence as NameSpace (tcName, varName)  import Test.Tasty.AutoCollect.GHC.Shim @@ -104,19 +105,19 @@ getSpanLine :: SrcSpan -> String getSpanLine loc =   case srcSpanStart loc of-    Right srcLoc -> "line " ++ show (srcLocLine srcLoc)-    Left s -> s+    RealSrcLoc srcLoc _ -> "line " ++ show (srcLocLine srcLoc)+    UnhelpfulLoc s -> unpackFS s  {----- Name utilities -----}  mkRdrName :: String -> RdrName-mkRdrName = mkRdrUnqual . mkOccNameVar+mkRdrName = mkRdrUnqual . mkOccName NameSpace.varName  mkLRdrName :: String -> LocatedN RdrName mkLRdrName = genLoc . mkRdrName  mkRdrNameType :: String -> RdrName-mkRdrNameType = mkRdrUnqual . mkOccNameTC+mkRdrNameType = mkRdrUnqual . mkOccName NameSpace.tcName  mkLRdrNameType :: String -> LocatedN RdrName mkLRdrNameType = genLoc . mkRdrNameType

@@ -4,9 +4,7 @@  -- 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+#if __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

@@ -1,229 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Test.Tasty.AutoCollect.GHC.Shim_8_10 (-  -- * Re-exports-  module X,--  -- * Compat--  -- ** Plugin-  setKeepRawTokenStream,-  withParsedResultModule,--  -- ** Annotations-  getExportComments,-  generatedSrcAnn,-  toSrcAnnA,--  -- ** SrcSpan-  srcSpanStart,--  -- ** OccName-  mkOccNameVar,-  mkOccNameTC,--  -- ** Decl-  parseDecl,--  -- ** Type-  parseSigWcType,-  parseType,--  -- ** Expr-  mkExplicitList,-  mkExplicitTuple,-  xAppTypeE,--  -- * Backports-  SrcAnn,-  SrcSpanAnn',-  LocatedN,-  unLoc,-  getLoc,-  getLocA,-  mkHsApps,-  mkMatch,-  noAnn,-  hsTypeToHsSigType,-  hsTypeToHsSigWcType,-  thNameToGhcNameIO,-) where---- Re-exports-import ApiAnnotation as X (AnnotationComment (..))-import GHC.Hs as X hiding (mkHsAppType, mkHsAppTypes, mkMatch)-import GhcPlugins as X hiding (getHscEnv, getLoc, showPpr, srcSpanStart, unLoc)-import HscMain as X (getHscEnv)-import NameCache as X (NameCache)--import ApiAnnotation (getAnnotationComments)-import Data.Foldable (foldl')-import Data.IORef (IORef)-import Data.Maybe (mapMaybe)-import qualified Data.Text as Text-import qualified GHC.Hs.Utils as GHC (mkMatch)-import qualified Language.Haskell.TH as TH-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-    }--withParsedResultModule :: HsParsedModule -> (HsParsedModule -> HsParsedModule) -> HsParsedModule-withParsedResultModule = flip ($)--{----- 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 / 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---- 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

@@ -17,13 +17,6 @@   generatedSrcAnn,   toSrcAnnA, -  -- ** SrcSpan-  srcSpanStart,--  -- ** OccName-  mkOccNameVar,-  mkOccNameTC,-   -- ** Decl   parseDecl, @@ -34,6 +27,7 @@   -- ** Expr   mkExplicitList,   mkExplicitTuple,+  mkLet,   xAppTypeE,    -- * Backports@@ -52,15 +46,13 @@ 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, showPpr, srcSpanStart, varName)+import GHC.Plugins as X hiding (getHscEnv, mkLet, showPpr, varName) import GHC.Types.Name.Cache as X (NameCache)  import Data.IORef (IORef) 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 qualified Language.Haskell.TH as TH  import Test.Tasty.AutoCollect.GHC.Shim_Common@@ -104,22 +96,6 @@ 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@@ -158,6 +134,9 @@  mkExplicitTuple :: [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs mkExplicitTuple = ExplicitTuple noAnn . map (L generatedSrcAnn)++mkLet :: HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs+mkLet binds expr = HsLet noExtField (L generatedSrcAnn binds) expr  xAppTypeE :: XAppTypeE GhcPs xAppTypeE = noExtField

@@ -18,13 +18,6 @@   getExportComments,   toSrcAnnA, -  -- ** SrcSpan-  srcSpanStart,--  -- ** OccName-  mkOccNameVar,-  mkOccNameTC,-   -- ** Decl   parseDecl, @@ -35,6 +28,7 @@   -- ** Expr   mkExplicitList,   mkExplicitTuple,+  mkLet,   xAppTypeE,    -- * Backports@@ -44,13 +38,18 @@ -- 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, showPpr, srcSpanStart, varName)+import GHC.Plugins as X hiding (+  AnnBind (..),+  AnnExpr' (..),+  getHscEnv,+  mkLet,+  showPpr,+  varName,+ ) import GHC.Types.Name.Cache as X (NameCache)  import Data.IORef (IORef) 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 qualified Language.Haskell.TH as TH  import Test.Tasty.AutoCollect.GHC.Shim_Common@@ -95,22 +94,6 @@ 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@@ -149,6 +132,9 @@  mkExplicitTuple :: [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs mkExplicitTuple = ExplicitTuple noAnn++mkLet :: HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs+mkLet binds expr = HsLet noAnn binds expr  xAppTypeE :: XAppTypeE GhcPs xAppTypeE = generatedSrcSpan

@@ -18,13 +18,6 @@   getExportComments,   toSrcAnnA, -  -- ** SrcSpan-  srcSpanStart,--  -- ** OccName-  mkOccNameVar,-  mkOccNameTC,-   -- ** Decl   parseDecl, @@ -35,6 +28,7 @@   -- ** Expr   mkExplicitList,   mkExplicitTuple,+  mkLet,   xAppTypeE,    -- * Backports@@ -48,9 +42,9 @@   AnnBind (..),   AnnExpr' (..),   getHscEnv,+  mkLet,   msg,   showPpr,-  srcSpanStart,   thNameToGhcNameIO,   varName,  )@@ -59,8 +53,6 @@ import qualified Data.Text as Text import qualified GHC.Data.Strict as Strict import qualified GHC.Plugins as GHC (thNameToGhcNameIO)-import qualified GHC.Types.Name.Occurrence as NameSpace (tcName, varName)-import qualified GHC.Types.SrcLoc as GHC (srcSpanStart) import qualified Language.Haskell.TH as TH  import Test.Tasty.AutoCollect.GHC.Shim_Common@@ -102,22 +94,6 @@ toSrcAnnA :: RealSrcSpan -> SrcSpanAnnA toSrcAnnA rss = SrcSpanAnn noAnn (RealSrcSpan rss Strict.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@@ -156,6 +132,9 @@  mkExplicitTuple :: [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs mkExplicitTuple = ExplicitTuple noAnn++mkLet :: HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs+mkLet binds expr = HsLet noAnn (L NoTokenLoc HsTok) binds (L NoTokenLoc HsTok) expr  xAppTypeE :: XAppTypeE GhcPs xAppTypeE = generatedSrcSpan

@@ -6,7 +6,9 @@   generateMainModule, ) where +import Control.Monad (guard) import qualified Data.ByteString as ByteString+import Data.Char (isDigit, isLower, isUpper) import Data.List (sortOn) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe)@@ -23,23 +25,37 @@ 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+generateMainModule :: AutoCollectConfig -> FilePath -> Text -> IO Text+generateMainModule cfg path originalMain = do   testModules <- sortOn displayName <$> findTestModules cfg path-  pure . Text.unlines $+  let importLines = map ("import qualified " <>) $ map moduleName testModules+      tests = generateTests cfg testModules+  pure $+    if cfgCustomMain cfg+      then rewriteMain importLines tests originalMain+      else mkMainModule cfg path importLines tests++rewriteMain :: [Text] -> Text -> Text -> Text+rewriteMain importLines tests =+  Text.replace "{- AUTOCOLLECT.MAIN.imports -}" (Text.unlines importLines)+    . Text.replace "{- AUTOCOLLECT.MAIN.tests -}" tests++mkMainModule :: AutoCollectConfig -> FilePath -> [Text] -> Text -> Text+mkMainModule AutoCollectConfig{..} path importLines tests =+  Text.unlines     [ "{-# OPTIONS_GHC -w #-}"     , ""     , "module Main (main) where"     , ""     , "import Test.Tasty"-    , Text.unlines . map ("import qualified " <>) $ map moduleName testModules ++ ingredientsModules+    , Text.unlines $ importLines ++ map ("import qualified " <>) ingredientsModules     , ""     , "main :: IO ()"     , "main = defaultMainWithIngredients ingredients (testGroup suiteName tests)"     , "  where"     , "    ingredients = " <> ingredients     , "    suiteName = " <> suiteName-    , "    tests = " <> generateTests cfg testModules+    , "    tests = " <> tests     ]   where     ingredients =@@ -65,12 +81,10 @@   -- ^ 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", ...]--}+-- | 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@@ -78,16 +92,26 @@      toTestModule fp = do       fileContentsBS <- ByteString.readFile fp-      return $-        case (splitExtensions fp, parseModuleType <$> Text.decodeUtf8' fileContentsBS) of-          ((fpNoExt, ".hs"), Right (Just ModuleTest)) ->-            let moduleName = Text.replace "/" "." . Text.pack . makeRelative testDir $ fpNoExt-             in Just+      pure $+        case splitExtensions fp of+          (fpNoExt, ".hs")+            | Right (Just ModuleTest) <- parseModuleType <$> Text.decodeUtf8' fileContentsBS+            , Just moduleName <- toModuleName $ Text.pack (makeRelative testDir fpNoExt) ->+                Just                   TestModule                     { moduleName                     , displayName = withoutSuffix (cfgStripSuffix cfg) moduleName                     }           _ -> Nothing++    toModuleName = fmap (Text.intercalate ".") . mapM validateModuleName . Text.splitOn "/"+    -- https://www.haskell.org/onlinereport/syntax-iso.html+    -- large { small | large | digit | ' }+    validateModuleName name = do+      (first, rest) <- Text.uncons name+      guard $ isUpper first+      guard $ Text.all (\c -> isUpper c || isLower c || isDigit c || c == '\'') rest+      Just name      mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]     mapMaybeM f = fmap catMaybes . mapM f

@@ -13,7 +13,7 @@ import Test.Tasty.AutoCollect.Constants  data ModuleType-  = ModuleMain AutoCollectConfig+  = ModuleMain AutoCollectConfigPartial   | ModuleTest   deriving (Show, Eq) @@ -29,11 +29,9 @@       | isTestComment (Text.unpack x) = Just ModuleTest     go (_ : rest) = go rest -{- |-Group consecutive whitespace characters.-->>> groupWhitespace " a  bb  c "-[" ", "a", "  ", "bb", "  ", "c", " "]--}+-- | Group consecutive whitespace characters.+--+-- >>> groupWhitespace " a  bb  c "+-- [" ", "a", "  ", "bb", "  ", "c", " "] groupWhitespace :: Text -> [Text] groupWhitespace = Text.groupBy (\c1 c2 -> isSpace c1 == isSpace c2)

@@ -16,49 +16,47 @@   }   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-        })-    ]-  }-@--}+-- | 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 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           tasty-autocollect-version:        0.3.2.0+version:        0.4.0 synopsis:       Autocollection of tasty tests. description:    Autocollection of tasty tests. See README.md for more details. category:       Testing@@ -61,24 +61,20 @@       Test.Tasty.AutoCollect.GHC.Shim_Common   hs-source-dirs:       src-  ghc-options: -Wall+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances   build-depends:       base >=4.14 && <5     , bytestring >=0.10 && <0.12     , containers >=0.6.2.1 && <0.7     , directory >=1.3.6.0 && <2     , filepath >=1.4.2.1 && <2-    , ghc >=8.10 && <9.5+    , ghc >=9.0 && <9.5     , tasty >=1.4.2.1 && <2     , tasty-expected-failure >=0.11 && <1     , template-haskell >=2.16 && <2.20     , text >=1.2.3.2 && <3     , transformers >=0.5.6.2 && <1   default-language: Haskell2010-  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.4) && impl(ghc < 9.6)     other-modules:         Test.Tasty.AutoCollect.GHC.Shim_9_4@@ -88,9 +84,6 @@   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  executable tasty-autocollect   main-is: Preprocessor.hs@@ -98,16 +91,12 @@       Paths_tasty_autocollect   hs-source-dirs:       exe-  ghc-options: -Wall+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances   build-depends:       base >=4.14 && <5     , tasty-autocollect     , text >=1.2.3.2 && <3   default-language: Haskell2010-  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  test-suite tasty-autocollect-tests   type: exitcode-stdio-1.0@@ -127,7 +116,7 @@       Paths_tasty_autocollect   hs-source-dirs:       test-  ghc-options: -Wall -F -pgmF=tasty-autocollect+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -F -pgmF=tasty-autocollect   build-depends:       base     , bytestring@@ -144,8 +133,4 @@     , text     , typed-process   default-language: Haskell2010-  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   build-tool-depends: tasty-autocollect:tasty-autocollect

@@ -9,10 +9,15 @@   -- $AUTOCOLLECT.TEST.export$ ) where +import Control.Monad (forM_) import Data.Bifunctor (first) import Data.Char (isSpace) import Data.Text (Text) import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import System.Directory (createDirectoryIfMissing)+import System.FilePath (takeDirectory, (</>))+import System.IO.Temp (withSystemTempDirectory) import Test.Predicates import Test.Predicates.HUnit import Test.Predicates.QuickCheck@@ -66,16 +71,21 @@  {----- Configuration options -----} +test =+  testCase "parseConfig parses import" $+    parseConfig "import = foo.conf, ../bar/baz.conf"+      @?~ right (cfgImports `with` just (eq ["foo.conf", "../bar/baz.conf"]))+ test_prop :: ConfigPiece -> Property test_prop "parseConfig parses suite_name" (ConfigPiece v) =   parseConfig ("suite_name = " <> v)-    `satisfies` right (cfgSuiteName `with` just (eq v))+    `satisfies` right (cfgSuiteName `with` just (just (eq v)))  test_prop :: Property test_prop "parseConfig parses group_type" =   forAll (elements groupTypeOptions) $ \(groupTypeName, groupType) ->     parseConfig ("group_type = " <> groupTypeName)-      `satisfies` right (cfgGroupType `with` eq groupType)+      `satisfies` right (cfgGroupType `with` just (eq groupType))  test_prop :: ConfigPiece -> Property test_prop "parseConfig errors on invalid group_type" (ConfigPiece v) =@@ -92,24 +102,24 @@ test_prop :: ConfigPiece -> Property test_prop "parseConfig parses strip_suffix" (ConfigPiece v) =   parseConfig ("strip_suffix = " <> v)-    `satisfies` right (cfgStripSuffix `with` eq v)+    `satisfies` right (cfgStripSuffix `with` just (eq v))  test_prop :: NonEmptyList HsIdentifier -> Property test_prop "parseConfig parses ingredients" (NonEmpty (map getHsIdentifier -> ingredients)) =   parseConfig ("ingredients = " <> Text.intercalate "," ingredients)-    `satisfies` right (cfgIngredients `with` eq ingredients)+    `satisfies` right (cfgIngredients `with` just (eq ingredients))  test_prop :: NonEmptyList (HsIdentifier, Spaces) -> Property test_prop "parseConfig strips whitespace when parsing ingredients" (NonEmpty (map (first getHsIdentifier) -> identifiers)) =   let ingredientsVal = Text.intercalate "," . map (\(s, spaces) -> wrapSpaces spaces s) $ identifiers       ingredients = map fst identifiers    in parseConfig ("ingredients = " <> ingredientsVal)-        `satisfies` right (cfgIngredients `with` eq ingredients)+        `satisfies` right (cfgIngredients `with` just (eq ingredients))  test_prop :: BoolOption -> Property test_prop "parseConfig parses ingredients_override (case insensitive)" option =   parseConfig ("ingredients_override = " <> getText option)-    `satisfies` right (cfgIngredientsOverride `with` eq (getBool option))+    `satisfies` right (cfgIngredientsOverride `with` just (eq (getBool option)))  test_prop :: ConfigPiece -> Property test_prop "parseConfig errors on invalid ingredients_override" (ConfigPiece v) =@@ -129,14 +139,42 @@       , "strip_suffix"       ] -{----- Helpers -----}+{----- Configuration resolution -----} -{- |-A Text suitable for use as a key or value in the configuration.+test =+  testCase "resolveConfig imports config recursively" $+    withSystemTempDirectory "tasty-autocollect-resolveConfig" $ \tmpdir -> do+      let+        files =+          [+            ( "foo/autocollect.conf"+            ,+              [ "import = ../base/autocollect.conf"+              , "suite_name = foo"+              ]+            )+          ,+            ( "base/autocollect.conf"+            ,+              [ "suite_name = base"+              , "ingredients = baseIngredients"+              ]+            )+          ]+      forM_ files $ \(fpRel, fileLines) -> do+        let fp = tmpdir </> fpRel+        createDirectoryIfMissing True (takeDirectory fp)+        Text.writeFile fp (Text.unlines fileLines)+      cfg <- resolveConfig (tmpdir </> "Main.hs") mempty{cfgImports = Just ["foo/autocollect.conf"]}+      cfgSuiteName cfg @?= Just "foo"+      cfgIngredients cfg @?= ["baseIngredients"] -Specifically, will be a non-empty string that does not contain '=',-newlines, or trailing/leading spaces.--}+{----- 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) 

@@ -81,7 +81,7 @@ test = testCase "tests fail when omitting export comment" $ do   (_, stderr) <-     assertAnyFailure . runTestWith (modifyFile "Test.hs" (map removeExports)) $-      [ "test = testCase \"a test\" $ return ()"+      [ "test = testCase \"a test\" $ pure ()"       ]   getTestLines stderr @?~ containsStripped (startsWith messagePreGHC94 `orP` startsWith messagePostGHC94)   where@@ -94,7 +94,7 @@ test = testCase "test file can omit an explicit export list" $ do   (stdout, _) <-     assertSuccess . runTestWith (modifyFile "Test.hs" (map removeExports)) $-      [ "test = testCase \"a test\" $ return ()"+      [ "test = testCase \"a test\" $ pure ()"       ]   getTestLines stdout @?~ containsStripped (eq "a test: OK")   where@@ -127,30 +127,30 @@   testCase "test may specify type" $     assertSuccess_ . runTest $       [ "test :: TestTree"-      , "test = testCase \"a test\" $ return ()"+      , "test = testCase \"a test\" $ pure ()"       ]  test = testGolden "test fails when given arguments" "test_args.golden" $ do   (_, stderr) <-     assertAnyFailure . runTest $-      [ "test \"some name\" = testCase \"test\" $ return ()"+      [ "test \"some name\" = testCase \"test\" $ pure ()"       ]-  return stderr+  pure stderr  test = testGolden "test fails when specifying wrong type" "test_type.golden" $ do   (_, stderr) <-     assertAnyFailure . runTest $       [ "test :: Int"-      , "test = testCase \"test\" $ return ()"+      , "test = testCase \"test\" $ pure ()"       ]-  return stderr+  pure stderr  test = testCase "tests can omit type signatures" $ do   (stdout, _) <-     assertSuccess . runTest $-      [ "test = testCase \"test 1\" $ return ()"+      [ "test = testCase \"test 1\" $ pure ()"       , ""-      , "test = testCase \"test 2\" $ return ()"+      , "test = testCase \"test 2\" $ pure ()"       ]   getTestLines stdout @?~ containsStripped (eq "test 1: OK")   getTestLines stdout @?~ containsStripped (eq "test 2: OK")@@ -159,9 +159,9 @@   testCase "tests may omit type after specifying a type prior" $     assertSuccess_ . runQCTest $       [ "test :: TestTree"-      , "test = testCase \"test 1\" $ return ()"+      , "test = testCase \"test 1\" $ pure ()"       , ""-      , "test = testCase \"test 2\" $ return ()"+      , "test = testCase \"test 2\" $ pure ()"       ]  {----- test_batch -----}@@ -170,7 +170,7 @@   (stdout, _) <-     assertSuccess . runTest $       [ "test_batch ="-      , "  [ testCase (\"test #\" ++ show x) $ return ()"+      , "  [ testCase (\"test #\" ++ show x) $ pure ()"       , "  | x <- [1 .. 5]"       , "  ]"       ]@@ -181,7 +181,7 @@   (stdout, _) <-     assertSuccess . runTest $       [ "test_batch ="-      , "  [ testCase (label x) $ return ()"+      , "  [ testCase (label x) $ pure ()"       , "  | x <- [1 .. 5]"       , "  ]"       , "  where"@@ -202,7 +202,7 @@     assertAnyFailure . runTest $       [ "test_batch \"some name\" = []"       ]-  return stderr+  pure stderr  test = testGolden "test_batch fails when specifying wrong type" "test_batch_type.golden" $ do   (_, stderr) <-@@ -210,7 +210,7 @@       [ "test_batch :: TestTree"       , "test_batch = []"       ]-  return stderr+  pure stderr  {----- test_prop -----} @@ -225,6 +225,15 @@     stdout @?~ hasSubstr "passed 100 tests"  test =+  testCase "test_prop where clause has args in scope" $+    assertSuccess_ . runQCTest $+      [ "test_prop :: Positive Int -> Bool"+      , "test_prop \"test\" (Positive n) = n > zero"+      , "  where"+      , "    zero = n - n"+      ]++test =   testCase "test_prop may omit type" $     assertSuccess_ . runQCTest $       [ "test_prop \"test\" x = (x :: Int) === x"@@ -254,12 +263,12 @@ test =   testGolden "test_prop fails when no arguments provided" "test_prop_no_args.golden" $ do     (_, stderr) <- assertAnyFailure $ runTest ["test_prop = 1 === 1"]-    return stderr+    pure stderr  test =   testGolden "test_prop fails when non-string argument provided" "test_prop_bad_arg.golden" $ do     (_, stderr) <- assertAnyFailure $ runTest ["test_prop 11 = True"]-    return stderr+    pure stderr  test =   testCase "test_prop works when -XOverloadedStrings is enabled" $@@ -285,7 +294,7 @@       assertSuccess . runTest $         [ "test_expectFail = testCase \"failing test\" $ 1 @?= 2"         ]-    return (normalizeTestOutput stdout)+    pure (normalizeTestOutput stdout)  test =   testGolden "expectFailBecause succeeds when test fails" "test_expectFailBecause_output.golden" $ do@@ -293,7 +302,7 @@       assertSuccess . runTest $         [ "test_expectFailBecause \"some reason\" = testCase \"failing test\" $ 1 @?= 2"         ]-    return (normalizeTestOutput stdout)+    pure (normalizeTestOutput stdout)  test =   testGolden "ignoreTest succeeds when test fails" "test_ignoreTest_output.golden" $ do@@ -301,7 +310,7 @@       assertSuccess . runTest $         [ "test_ignoreTest = testCase \"failing test\" $ 1 @?= 2"         ]-    return (normalizeTestOutput stdout)+    pure (normalizeTestOutput stdout)  test =   testGolden "ignoreTestBecause succeeds when test fails" "test_ignoreTestBecause_output.golden" $ do@@ -309,7 +318,7 @@       assertSuccess . runTest $         [ "test_ignoreTestBecause \"some reason\" = testCase \"failing test\" $ 1 @?= 2"         ]-    return (normalizeTestOutput stdout)+    pure (normalizeTestOutput stdout)  test =   testGolden "expected-failure modifiers work on test_batch" "test_batch_expectFailBecause_output.golden" $ do@@ -320,7 +329,7 @@         , "  | x <- [1 .. 3 :: Int]"         , "  ]"         ]-    return (normalizeTestOutput stdout)+    pure (normalizeTestOutput stdout)  test =   testCase "expected-failure modifiers work on test_prop" $ do

@@ -35,7 +35,7 @@       [ "{- AUTOCOLLECT.TEST -}"       , "module A.B.C.X.Y.Z where"       , "import Test.Tasty.HUnit"-      , "test = testCase \"test\" $ return ()"+      , "test = testCase \"test\" $ pure ()"       ]  test =@@ -52,6 +52,16 @@         )         ["{- AUTOCOLLECT.MAIN -}"] +test =+  testCase "ignores directories with invalid module name" $+    assertSuccess_ . runMainWith (addFiles [("A/&Bad/Foo.hs", ["{- AUTOCOLLECT.TEST -}"])]) $+      ["{- AUTOCOLLECT.MAIN -}"]++test =+  testCase "ignores files with invalid module name" $+    assertSuccess_ . runMainWith (addFiles [("A/#Foo#.hs", ["{- AUTOCOLLECT.TEST -}"])]) $+      ["{- AUTOCOLLECT.MAIN -}"]+ test_batch =   [ testGolden     ("output for group_type = " <> groupType <> " is as expected")@@ -77,8 +87,8 @@       [ "{- AUTOCOLLECT.TEST -}"       , "module " <> moduleName <> " where"       , "import Test.Tasty.HUnit"-      , "test = testCase \"test #1 for " <> ident <> "\" $ return ()"-      , "test = testCase \"test #2 for " <> ident <> "\" $ return ()"+      , "test = testCase \"test #1 for " <> ident <> "\" $ pure ()"+      , "test = testCase \"test #2 for " <> ident <> "\" $ pure ()"       ]  test = testCase "generateMain orders test modules alphabetically" $ do@@ -114,7 +124,7 @@       [ "{- AUTOCOLLECT.TEST -}"       , "module " <> moduleName <> " where"       , "import Test.Tasty.HUnit"-      , "test = testCase \"test\" $ return ()"+      , "test = testCase \"test\" $ pure ()"       ]  test = testCase "allows stripping suffix from test modules" $ do@@ -142,7 +152,7 @@       [ "{- AUTOCOLLECT.TEST -}"       , "module " <> moduleName <> " where"       , "import Test.Tasty.HUnit"-      , "test = testCase \"test\" $ return ()"+      , "test = testCase \"test\" $ pure ()"       ]  test = testCase "suffix is stripped before building module tree" $ do@@ -171,7 +181,7 @@           [ "{- AUTOCOLLECT.TEST -}"           , "module A.B.CTest where"           , "import Test.Tasty.HUnit"-          , "test = testCase \"test1\" $ return ()"+          , "test = testCase \"test1\" $ pure ()"           ]         )       ,@@ -180,7 +190,7 @@           [ "{- AUTOCOLLECT.TEST -}"           , "module A.B.C.DTest where"           , "import Test.Tasty.HUnit"-          , "test = testCase \"test2\" $ return ()"+          , "test = testCase \"test2\" $ pure ()"           ]         )       ]@@ -199,7 +209,7 @@       , "import Test.Tasty.Ingredients"       , "sayHelloAndExit :: Ingredient"       , "sayHelloAndExit = TestManager [] $ \\_ _ -> Just $"-      , "  putStrLn \"Hello!\" >> return True"+      , "  putStrLn \"Hello!\" >> pure True"       ]  test = testCase "gives informative error when ingredient lacks module" $ do@@ -229,6 +239,75 @@       ]   stdout @?~ startsWith "my-test-suite" +test = testCase "allows importing configuration" $ do+  (stdout, _) <-+    assertSuccess . runMainWith (addFiles [("autocollect.conf", config), testFile]) $+      [ "{- AUTOCOLLECT.MAIN"+      , "import = autocollect.conf"+      , "suite_name = my-actual-test-suite"+      , "-}"+      ]+  stdout @?~ startsWith "my-actual-test-suite"+  getTestLines stdout @?~ containsStripped (eq "MyLibrary")+  where+    config =+      [ "# this is a comment in imported config"+      , "suite_name = my-test-suite"+      , "strip_suffix = Test"+      ]+    testFile =+      ( "MyLibraryTest.hs"+      ,+        [ "{- AUTOCOLLECT.TEST -}"+        , "module MyLibraryTest where"+        , "import Test.Tasty.HUnit"+        , "test = testCase \"my test\" $ pure ()"+        ]+      )++test = testCase "allows customizing main module" $ do+  (stdout, _) <-+    assertSuccess . runMainWith (setTestFiles testFiles) $+      [ "{- AUTOCOLLECT.MAIN"+      , "custom_main = true"+      , "group_type = modules"+      , "strip_suffix = Test"+      , "-}"+      , ""+      , "{- AUTOCOLLECT.MAIN.imports -}"+      , "import Test.Tasty"+      , ""+      , "main :: IO ()"+      , "main = do"+      , "  putStrLn \"hello world!\""+      , "  defaultMain $ testGroup \"my tests\" tests"+      , "  where"+      , "    tests = id {- AUTOCOLLECT.MAIN.tests -}"+      ]+  getTestLines stdout+    @?~ startsWith+      [ "hello world!"+      , "my tests"+      , "  A"+      , "    test: OK"+      , "  A.A"+      , "    test: OK"+      , "  B"+      , "    test: OK"+      ]+  where+    testFiles =+      [ ("A.hs", testFile "A")+      , ("A/ATest.hs", testFile "A.ATest")+      , ("BTest.hs", testFile "BTest")+      ]+    testFile moduleName =+      [ "{- AUTOCOLLECT.TEST -}"+      , "module " <> moduleName <> " where"+      , "import Test.Tasty.HUnit"+      , "test = testCase \"test\" $ pure ()"+      ]+ {----- Helpers -----}  setTestFiles :: [(FilePath, FileContents)] -> GHCProject -> GHCProject@@ -264,6 +343,6 @@         , "import Test.Tasty"         , "import Test.Tasty.HUnit"         , ""-        , "test = testCase \"a test in " <> moduleName <> "\" $ return ()"+        , "test = testCase \"a test in " <> moduleName <> "\" $ pure ()"         ]       )

@@ -36,6 +36,6 @@  test = testCase "parseModuleType parses configuration for main modules" $ do   parseModuleType "{- AUTOCOLLECT.MAIN suite_name = foo -}"-    @?~ just ($(qADT 'ModuleMain) $ cfgSuiteName `with` eq (Just "foo"))+    @?~ just ($(qADT 'ModuleMain) $ cfgSuiteName `with` eq (Just $ Just "foo"))   parseModuleType "{- AUTOCOLLECT.MAIN\nsuite_name = foo\n-}"-    @?~ just ($(qADT 'ModuleMain) $ cfgSuiteName `with` eq (Just "foo"))+    @?~ just ($(qADT 'ModuleMain) $ cfgSuiteName `with` eq (Just $ Just "foo"))

@@ -29,7 +29,7 @@     assertAnyFailure . runTest $       [ "test_todo \"some name\" = \"a pending test\""       ]-  return stderr+  pure stderr  test = testGolden "test_todo fails when specifying wrong type" "test_todo_type.golden" $ do   (_, stderr) <-@@ -37,7 +37,7 @@       [ "test_todo :: Int"       , "test_todo = \"a pending test\""       ]-  return stderr+  pure stderr  test =   testGolden "--fail-todos makes TODO tests fail" "fail_todos.golden" $ do@@ -46,4 +46,4 @@         runTestWith           (\proj -> proj{runArgs = ["--fail-todos"]})           ["test_todo = \"a pending test\""]-    return $ normalizeTestOutput stdout+    pure $ normalizeTestOutput stdout

@@ -49,7 +49,7 @@ assertStatus isExpected testResult = do   (code, stdout, stderr) <- testResult   if isExpected code-    then return (stdout, stderr)+    then pure (stdout, stderr)     else       errorWithoutStackTrace . unlines $         [ "Got: " ++ show code@@ -123,17 +123,15 @@           , "--" : entrypoint : map Text.unpack runArgs           ] -    return (code, decode stdout, decode stderr)+    pure (code, decode stdout, decode stderr)   where     decode = TextL.toStrict . TextL.decodeUtf8  {----- Helpers -----} -{- |-Run a test file with tasty-autocollect.--Automatically imports Test.Tasty and Test.Tasty.HUnit.--}+-- | Run a test file with tasty-autocollect.+--+-- Automatically imports Test.Tasty and Test.Tasty.HUnit. runTest :: FileContents -> IO (ExitCode, Text, Text) runTest = runTestWith id 

@@ -9,14 +9,12 @@ 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.--}+-- | 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

@@ -2,5 +2,5 @@ <no location info>: error:      ******************** tasty-autocollect failure ********************-test should not be used with arguments (at line 5)+Found extraneous arguments at line 5 

@@ -2,5 +2,5 @@ <no location info>: error:      ******************** tasty-autocollect failure ********************-test_batch should not be used with arguments (at line 5)+Found extraneous arguments at line 5 

@@ -2,5 +2,5 @@ <no location info>: error:      ******************** tasty-autocollect failure ********************-test_todo should not be used with arguments (at line 5)+Found extraneous arguments at line 5