tasty-autocollect 0.4.2 → 0.4.3

raw patch · 19 files changed

+220/−173 lines, 19 filesdep ~containersdep ~ghcdep ~template-haskell

Dependency ranges changed: containers, ghc, template-haskell

Files

• CHANGELOG.md +5/−0
• src/Test/Tasty/AutoCollect/ConvertTest.hs +1/−1
• src/Test/Tasty/AutoCollect/Error.hs +3/−1
• src/Test/Tasty/AutoCollect/GHC.hs +24/−28
• src/Test/Tasty/AutoCollect/GHC/Shim.hs +3/−3
• src/Test/Tasty/AutoCollect/GHC/Shim_9_10.hs +83/−0
• src/Test/Tasty/AutoCollect/GHC/Shim_9_4.hs +0/−69
• src/Test/Tasty/AutoCollect/GHC/Shim_9_6.hs +38/−22
• src/Test/Tasty/AutoCollect/GHC/Shim_9_8.hs +38/−22
• tasty-autocollect.cabal +7/−7
• test/TestUtils/Golden.hs +18/−8
• test/golden/test_args.golden +0/−1
• test/golden/test_batch_args.golden +0/−1
• test/golden/test_batch_type.golden +0/−2
• test/golden/test_prop_bad_arg.golden +0/−2
• test/golden/test_prop_no_args.golden +0/−1
• test/golden/test_todo_args.golden +0/−1
• test/golden/test_todo_type.golden +0/−2
• test/golden/test_type.golden +0/−2

@@ -1,3 +1,8 @@+# v0.4.3++* Add support for GHC 9.10+* Drop support for GHC 9.4+ # v0.4.2  * Add support for GHC 9.8

@@ -91,7 +91,7 @@       if isTestExportComment comment         then Just loc         else Nothing-    exportIE = mkIEVar $ genLoc $ mkIEName testListName+    exportIE = mkIEVar $ genLoc $ IEName noExtField testListName      -- Generate the `tests` list     mkTestsList :: [LocatedN RdrName] -> [LHsDecl GhcPs]

@@ -2,11 +2,13 @@   autocollectError, ) where +import Data.List (dropWhileEnd)+ import Test.Tasty.AutoCollect.GHC  autocollectError :: String -> a autocollectError msg =-  pgmError . unlines $+  pgmError . dropWhileEnd (== '\n') . unlines $     [ ""     , "******************** tasty-autocollect failure ********************"     , msg

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}@@ -9,6 +10,7 @@   showPpr,    -- * Parsers+  parseDecl,   parseLitStrPat,   parseSigWcType, @@ -19,16 +21,12 @@   mkHsVar,   mkHsAppTypes,   mkHsTyVar,-  mkLet,   mkExprTypeSig,-  mkHsLitString,    -- * Annotation utilities-  toSrcAnnA,   getExportComments,    -- * Located utilities-  genLoc,   firstLocatedWhere,   getSpanLine, @@ -40,20 +38,19 @@   fromRdrName, ) where +#if __GLASGOW_HASKELL__ < 910 import Data.Foldable (foldl')+#endif import Data.List (sortOn) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Text qualified as Text-import GHC.Data.Strict qualified as Strict import GHC.Types.Name.Occurrence qualified as NameSpace (tcName, varName)  import Test.Tasty.AutoCollect.GHC.Shim hiding (   mkHsAppTypes,-  mkLet,   msg,   showPpr,  )-import Test.Tasty.AutoCollect.Utils.Text (withoutPrefix, withoutSuffix)  {----- Output helpers -----} @@ -62,6 +59,23 @@  {----- Parsers ----} +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+ parseLitStrPat :: LPat GhcPs -> Maybe String parseLitStrPat = \case   L _ (LitPat _ (HsString _ s)) -> Just (unpackFS s)@@ -107,40 +121,22 @@ mkHsTyVar :: Name -> LHsType GhcPs mkHsTyVar = genLoc . HsTyVar noAnn NotPromoted . genLoc . getRdrName -mkLet :: HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs-mkLet binds expr = HsLet noAnn (L NoTokenLoc HsTok) binds (L NoTokenLoc HsTok) expr- -- | mkExprTypeSig e t = [| $e :: $t |] mkExprTypeSig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs mkExprTypeSig e t =   genLoc . ExprWithTySig noAnn e $     HsWC NoExtField (hsTypeToHsSigType t) -mkHsLitString :: String -> LHsExpr GhcPs-mkHsLitString = genLoc . HsLit noAnn . mkHsString- {----- Annotation utilities -----} -toSrcAnnA :: RealSrcSpan -> SrcSpanAnnA-toSrcAnnA rss = SrcSpanAnn noAnn (RealSrcSpan rss Strict.Nothing)- -- | Get the contents of all comments in the given hsmodExports list. getExportComments :: LocatedL [LIE GhcPs] -> [RealLocated String]-getExportComments = map fromLEpaComment . priorComments . epAnnComments . ann . getLoc+getExportComments = map fromLEpaComment . priorComments . epAnnComments . getEpAnn   where-    fromLEpaComment (L Anchor{anchor} EpaComment{ac_tok}) =-      L anchor $ (Text.unpack . Text.strip . unwrap) ac_tok-    unwrap = \case-      EpaDocComment doc -> Text.pack $ renderHsDocString doc-      EpaDocOptions s -> Text.pack s-      EpaLineComment s -> withoutPrefix "--" $ Text.pack s-      EpaBlockComment s -> withoutPrefix "{-" . withoutSuffix "-}" $ Text.pack s-      EpaEofComment -> ""+    fromLEpaComment (L ann EpaComment{ac_tok}) =+      L (anchor ann) $ (Text.unpack . Text.strip . epaCommentTokText) ac_tok  {----- Located utilities -----}--genLoc :: e -> GenLocated (SrcAnn ann) e-genLoc = L (SrcSpanAnn noAnn generatedSrcSpan)  firstLocatedWhere :: (Ord l) => (GenLocated l e -> Maybe a) -> [GenLocated l e] -> Maybe a firstLocatedWhere f = listToMaybe . mapMaybe f . sortOn getLoc

@@ -4,10 +4,10 @@  -- GHC-specific shims import Test.Tasty.AutoCollect.GHC.Shim_Common as X-#if __GLASGOW_HASKELL__ == 904-import Test.Tasty.AutoCollect.GHC.Shim_9_4 as X-#elif __GLASGOW_HASKELL__ == 906+#if __GLASGOW_HASKELL__ == 906 import Test.Tasty.AutoCollect.GHC.Shim_9_6 as X #elif __GLASGOW_HASKELL__ == 908 import Test.Tasty.AutoCollect.GHC.Shim_9_8 as X+#elif __GLASGOW_HASKELL__ == 910+import Test.Tasty.AutoCollect.GHC.Shim_9_10 as X #endif

@@ -0,0 +1,83 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Tasty.AutoCollect.GHC.Shim_9_10 (+  -- * Re-exports+  module X,++  -- * Compat++  -- ** Decl+  generatedOrigin,++  -- ** Expr+  mkHsAppType,+  mkLet,+  mkHsLitString,++  -- ** Name+  mkIEVar,++  -- ** Annotations + Located+  getEpAnn,+  toSrcAnnA,+  genLoc,+  epaCommentTokText,+) where++-- Re-exports+import GHC.Driver.Main as X (getHscEnv)+import GHC.Hs as X hiding (mkHsAppType)+import GHC.Plugins as X hiding (+  AnnBind (..),+  AnnExpr' (..),+  getHscEnv,+  mkLet,+ )+import GHC.Types.Name.Cache as X (NameCache)++import Data.Text (Text)+import Data.Text qualified as Text++import Test.Tasty.AutoCollect.Utils.Text (withoutPrefix, withoutSuffix)++{----- Compat / Decl -----}++generatedOrigin :: Origin+generatedOrigin = Generated OtherExpansion DoPmc++{----- Compat / Expr -----}++mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> HsExpr GhcPs+mkHsAppType e t = HsAppType NoEpTok e (HsWC noExtField t)++mkLet :: HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs+mkLet binds expr = HsLet (NoEpTok, NoEpTok) binds expr++mkHsLitString :: String -> LHsExpr GhcPs+mkHsLitString = genLoc . HsLit noExtField . mkHsString++{----- Compat / Name -----}++mkIEVar :: LIEWrappedName GhcPs -> IE GhcPs+mkIEVar n = IEVar Nothing n Nothing++{----- Compat / Annotations + Located -----}++getEpAnn :: GenLocated (EpAnn ann) e -> EpAnn ann+getEpAnn = getLoc++toSrcAnnA :: RealSrcSpan -> SrcSpanAnnA+toSrcAnnA rss = EpAnn (realSpanAsAnchor rss) noAnn (EpaComments [])++genLoc :: (NoAnn ann) => e -> GenLocated (EpAnn ann) e+genLoc = L noAnn++epaCommentTokText :: EpaCommentTok -> Text+epaCommentTokText = \case+  EpaDocComment doc -> Text.pack $ renderHsDocString doc+  EpaDocOptions s -> Text.pack s+  EpaLineComment s -> withoutPrefix "--" $ Text.pack s+  EpaBlockComment s -> withoutPrefix "{-" . withoutSuffix "-}" $ Text.pack s

@@ -1,69 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Test.Tasty.AutoCollect.GHC.Shim_9_4 (-  -- * Re-exports-  module X,--  -- * Compat--  -- ** Decl-  parseDecl,-  generatedOrigin,--  -- ** Expr-  mkHsAppType,--  -- ** Name-  mkIEVar,-  mkIEName,-) where---- Re-exports-import GHC.Driver.Main as X (getHscEnv)-import GHC.Hs as X hiding (mkHsAppType)-import GHC.Plugins as X hiding (-  AnnBind (..),-  AnnExpr' (..),-  getHscEnv,- )-import GHC.Types.Name.Cache as X (NameCache)--import Test.Tasty.AutoCollect.GHC.Shim_Common--{----- 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--generatedOrigin :: Origin-generatedOrigin = Generated--{----- Compat / Expr -----}--mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> HsExpr GhcPs-mkHsAppType e t = HsAppType generatedSrcSpan e (HsWC noExtField t)--{----- Compat / Name -----}--mkIEVar :: LIEWrappedName (IdP GhcPs) -> IE GhcPs-mkIEVar = IEVar noExtField--mkIEName :: LocatedN RdrName -> IEWrappedName RdrName-mkIEName = IEName

@@ -10,15 +10,21 @@   -- * Compat    -- ** Decl-  parseDecl,   generatedOrigin,    -- ** Expr   mkHsAppType,+  mkLet,+  mkHsLitString,    -- ** Name   mkIEVar,-  mkIEName,++  -- ** Annotations + Located+  getEpAnn,+  toSrcAnnA,+  genLoc,+  epaCommentTokText, ) where  -- Re-exports@@ -28,29 +34,17 @@   AnnBind (..),   AnnExpr' (..),   getHscEnv,+  mkLet,  ) import GHC.Types.Name.Cache as X (NameCache) -import Test.Tasty.AutoCollect.GHC.Shim_Common+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Data.Strict qualified as Strict -{----- Compat / Decl -----}+import Test.Tasty.AutoCollect.Utils.Text (withoutPrefix, withoutSuffix) -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 / Decl -----}  generatedOrigin :: Origin generatedOrigin = Generated@@ -60,10 +54,32 @@ mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> HsExpr GhcPs mkHsAppType e t = HsAppType noExtField e (L NoTokenLoc HsTok) (HsWC noExtField t) +mkLet :: HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs+mkLet binds expr = HsLet noAnn (L NoTokenLoc HsTok) binds (L NoTokenLoc HsTok) expr++mkHsLitString :: String -> LHsExpr GhcPs+mkHsLitString = genLoc . HsLit noAnn . mkHsString+ {----- Compat / Name -----}  mkIEVar :: LIEWrappedName GhcPs -> IE GhcPs mkIEVar = IEVar noExtField -mkIEName :: LocatedN RdrName -> IEWrappedName GhcPs-mkIEName = IEName noExtField+{----- Compat / Annotations + Located -----}++getEpAnn :: GenLocated (SrcAnn ann) e -> EpAnn ann+getEpAnn = ann . getLoc++toSrcAnnA :: RealSrcSpan -> SrcSpanAnnA+toSrcAnnA rss = SrcSpanAnn noAnn (RealSrcSpan rss Strict.Nothing)++genLoc :: e -> GenLocated (SrcAnn ann) e+genLoc = L (SrcSpanAnn noAnn generatedSrcSpan)++epaCommentTokText :: EpaCommentTok -> Text+epaCommentTokText = \case+  EpaDocComment doc -> Text.pack $ renderHsDocString doc+  EpaDocOptions s -> Text.pack s+  EpaLineComment s -> withoutPrefix "--" $ Text.pack s+  EpaBlockComment s -> withoutPrefix "{-" . withoutSuffix "-}" $ Text.pack s+  EpaEofComment -> ""

@@ -10,15 +10,21 @@   -- * Compat    -- ** Decl-  parseDecl,   generatedOrigin,    -- ** Expr   mkHsAppType,+  mkLet,+  mkHsLitString,    -- ** Name   mkIEVar,-  mkIEName,++  -- ** Annotations + Located+  getEpAnn,+  toSrcAnnA,+  genLoc,+  epaCommentTokText, ) where  -- Re-exports@@ -28,29 +34,17 @@   AnnBind (..),   AnnExpr' (..),   getHscEnv,+  mkLet,  ) import GHC.Types.Name.Cache as X (NameCache) -import Test.Tasty.AutoCollect.GHC.Shim_Common+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Data.Strict qualified as Strict -{----- Compat / Decl -----}+import Test.Tasty.AutoCollect.Utils.Text (withoutPrefix, withoutSuffix) -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 / Decl -----}  generatedOrigin :: Origin generatedOrigin = Generated DoPmc@@ -60,10 +54,32 @@ mkHsAppType :: LHsExpr GhcPs -> LHsType GhcPs -> HsExpr GhcPs mkHsAppType e t = HsAppType noExtField e (L NoTokenLoc HsTok) (HsWC noExtField t) +mkLet :: HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs+mkLet binds expr = HsLet noAnn (L NoTokenLoc HsTok) binds (L NoTokenLoc HsTok) expr++mkHsLitString :: String -> LHsExpr GhcPs+mkHsLitString = genLoc . HsLit noAnn . mkHsString+ {----- Compat / Name -----}  mkIEVar :: LIEWrappedName GhcPs -> IE GhcPs mkIEVar = IEVar Nothing -mkIEName :: LocatedN RdrName -> IEWrappedName GhcPs-mkIEName = IEName noExtField+{----- Compat / Annotations + Located -----}++getEpAnn :: GenLocated (SrcAnn ann) e -> EpAnn ann+getEpAnn = ann . getLoc++toSrcAnnA :: RealSrcSpan -> SrcSpanAnnA+toSrcAnnA rss = SrcSpanAnn noAnn (RealSrcSpan rss Strict.Nothing)++genLoc :: e -> GenLocated (SrcAnn ann) e+genLoc = L (SrcSpanAnn noAnn generatedSrcSpan)++epaCommentTokText :: EpaCommentTok -> Text+epaCommentTokText = \case+  EpaDocComment doc -> Text.pack $ renderHsDocString doc+  EpaDocOptions s -> Text.pack s+  EpaLineComment s -> withoutPrefix "--" $ Text.pack s+  EpaBlockComment s -> withoutPrefix "{-" . withoutSuffix "-}" $ Text.pack s+  EpaEofComment -> ""

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           tasty-autocollect-version:        0.4.2+version:        0.4.3 synopsis:       Autocollection of tasty tests. description:    Autocollection of tasty tests. See README.md for more details. category:       Testing@@ -67,25 +67,25 @@   build-depends:       base >=4.17 && <5     , bytestring <0.13-    , containers <0.7+    , containers <0.8     , directory <2     , filepath <2-    , ghc >=9.4 && <9.9+    , ghc >=9.4 && <9.11     , tasty <2     , tasty-expected-failure <1-    , template-haskell >=2.19 && <2.22+    , template-haskell >=2.19 && <2.23     , text <3     , transformers <1   default-language: Haskell2010+  if impl(ghc >= 9.10) && impl(ghc < 9.12)+    other-modules:+        Test.Tasty.AutoCollect.GHC.Shim_9_10   if impl(ghc >= 9.8) && impl(ghc < 9.10)     other-modules:         Test.Tasty.AutoCollect.GHC.Shim_9_8   if impl(ghc >= 9.6) && impl(ghc < 9.8)     other-modules:         Test.Tasty.AutoCollect.GHC.Shim_9_6-  if impl(ghc >= 9.4) && impl(ghc < 9.6)-    other-modules:-        Test.Tasty.AutoCollect.GHC.Shim_9_4  executable tasty-autocollect   main-is: Preprocessor.hs

@@ -8,6 +8,7 @@ ) where  import Data.Text (Text)+import Data.Text qualified as Text import Data.Text.Lazy qualified as TextL import Data.Text.Lazy.Encoding qualified as TextL import System.Environment (lookupEnv)@@ -20,7 +21,12 @@ #endif  testGolden :: String -> FilePath -> IO Text -> TestTree-testGolden name fp = goldenVsString name ("test/golden/" ++ fp) . fmap (TextL.encodeUtf8 . TextL.fromStrict . normalizePgmError)+testGolden name fp = goldenVsString name ("test/golden/" ++ fp) . fmap encodeText+  where+    encodeText = TextL.encodeUtf8 . TextL.fromStrict . normalize+    normalize t+      | "tasty-autocollect failure" `Text.isInfixOf` t = normalizeAutocollectError t+      | otherwise = t  testGoldenVersioned :: String -> FilePath -> IO Text -> TestTree testGoldenVersioned name fp = testGolden name fp'@@ -30,12 +36,16 @@         Just "1" -> fp <> ".prefer-oldest"         _ -> fp --- GHC 9.4 added a prefix to pgmError messages. Normalize old versions to show new format.-normalizePgmError :: Text -> Text-#if __GLASGOW_HASKELL__ >= 904-normalizePgmError = id+normalizeAutocollectError :: Text -> Text+#if __GLASGOW_HASKELL__ >= 910+normalizeAutocollectError = id #else-normalizePgmError t-  | "tasty-autocollect failure" `Text.isInfixOf` t =  "\n<no location info>: error:\n    " <> t-  | otherwise = t+-- GHC < 9.10 had an extra newline at the beginning. Strip this.+-- GHC < 9.10 also has one fewer newline at the end. Add one.+normalizeAutocollectError = (<> "\n") . stripLeadingNewline+  where+    stripLeadingNewline t =+      case Text.uncons t of+        Just ('\n', t') -> t'+        _ -> t #endif

@@ -1,4 +1,3 @@- <no location info>: error:      ******************** tasty-autocollect failure ********************

@@ -1,4 +1,3 @@- <no location info>: error:      ******************** tasty-autocollect failure ********************

@@ -1,8 +1,6 @@- <no location info>: error:      ******************** tasty-autocollect failure ******************** Expected type: [TestTree] Got: TestTree- 

@@ -1,8 +1,6 @@- <no location info>: error:      ******************** tasty-autocollect failure ******************** test_prop expected a String for the name of the test. Got: 11- 

@@ -1,4 +1,3 @@- <no location info>: error:      ******************** tasty-autocollect failure ********************

@@ -1,4 +1,3 @@- <no location info>: error:      ******************** tasty-autocollect failure ********************

@@ -1,8 +1,6 @@- <no location info>: error:      ******************** tasty-autocollect failure ******************** Expected type: String Got: Int- 

@@ -1,8 +1,6 @@- <no location info>: error:      ******************** tasty-autocollect failure ******************** Expected type: TestTree Got: Int-