Cabal-tests/tests/ParserTests.hs

   1 {-# LANGUAGE CPP #-}
   2 module Main
   3     ( main
   4     ) where
   5
   6 import Prelude ()
   7 import Prelude.Compat
   8
   9 import Test.Tasty
  10 import Test.Tasty.Golden.Advanced (goldenTest)
  11 import Test.Tasty.HUnit
  12
  13 import Control.Monad                               (unless, void)
  14 import Data.Algorithm.Diff                         (PolyDiff (..), getGroupedDiff)
  15 import Data.Maybe                                  (isNothing)
  16 import Distribution.Fields                         (runParseResult)
  17 import Distribution.PackageDescription             (GenericPackageDescription)
  18 import Distribution.PackageDescription.Parsec      (parseGenericPackageDescription)
  19 import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
  20 import Distribution.Parsec                         (PWarnType (..), PWarning (..), showPError, showPWarning)
  21 import Distribution.Pretty                         (prettyShow)
  22 import Distribution.Utils.Generic                  (fromUTF8BS, toUTF8BS)
  23 import System.Directory                            (setCurrentDirectory)
  24 import System.Environment                          (getArgs, withArgs)
  25 import System.FilePath                             (replaceExtension, (</>))
  26
  27 import qualified Data.ByteString       as BS
  28 import qualified Data.ByteString.Char8 as BS8
  29 import qualified Data.List.NonEmpty    as NE
  30
  31 import qualified Distribution.InstalledPackageInfo as IPI
  32
  33 #ifdef MIN_VERSION_tree_diff
  34 import Data.TreeDiff                 (ansiWlEditExpr, ediff, toExpr)
  35 import Data.TreeDiff.Golden          (ediffGolden)
  36 import Data.TreeDiff.Instances.Cabal ()
  37 #endif
  38
  39 tests :: TestTree
  40 tests = testGroup "parsec tests"
  41     [ regressionTests
  42     , warningTests
  43     , errorTests
  44     , ipiTests
  45     ]
  46
  47 -------------------------------------------------------------------------------
  48 -- Warnings
  49 -------------------------------------------------------------------------------
  50
  51 -- Verify that we trigger warnings
  52 warningTests :: TestTree
  53 warningTests = testGroup "warnings triggered"
  54     [ warningTest PWTLexBOM            "bom.cabal"
  55     , warningTest PWTLexNBSP           "nbsp.cabal"
  56     , warningTest PWTLexTab            "tab.cabal"
  57     , warningTest PWTUTF               "utf8.cabal"
  58     , warningTest PWTBoolCase          "bool.cabal"
  59     , warningTest PWTVersionTag        "versiontag.cabal"
  60     , warningTest PWTNewSyntax         "newsyntax.cabal"
  61     , warningTest PWTOldSyntax         "oldsyntax.cabal"
  62     , warningTest PWTDeprecatedField   "deprecatedfield.cabal"
  63     , warningTest PWTInvalidSubsection "subsection.cabal"
  64     , warningTest PWTUnknownField      "unknownfield.cabal"
  65     , warningTest PWTUnknownSection    "unknownsection.cabal"
  66     , warningTest PWTTrailingFields    "trailingfield.cabal"
  67     , warningTest PWTDoubleDash        "doubledash.cabal"
  68     , warningTest PWTMultipleSingularField "multiplesingular.cabal"
  69     , warningTest PWTVersionWildcard   "wildcard.cabal"
  70     , warningTest PWTVersionOperator   "operator.cabal"
  71     , warningTest PWTSpecVersion       "specversion-a.cabal"
  72     , warningTest PWTSpecVersion       "specversion-b.cabal"
  73     , warningTest PWTSpecVersion       "specversion-c.cabal"
  74     -- TODO: not implemented yet
  75     -- , warningTest PWTExtraTestModule   "extratestmodule.cabal"
  76     ]
  77
  78 warningTest :: PWarnType -> FilePath -> TestTree
  79 warningTest wt fp = testCase (show wt) $ do
  80     contents <- BS.readFile $ "tests" </> "ParserTests" </> "warnings" </> fp
  81
  82     let res =  parseGenericPackageDescription contents
  83     let (warns, x) = runParseResult res
  84
  85     assertBool ("should parse successfully: " ++ show x) $ isRight x
  86
  87     case warns of
  88         [PWarning wt' _ _] -> assertEqual "warning type" wt wt'
  89         []                 -> assertFailure "got no warnings"
  90         _                  -> assertFailure $ "got multiple warnings: " ++ show warns
  91   where
  92     isRight (Right _) = True
  93     isRight _         = False
  94
  95 -------------------------------------------------------------------------------
  96 -- Errors
  97 -------------------------------------------------------------------------------
  98
  99 errorTests :: TestTree
 100 errorTests = testGroup "errors"
 101     [ errorTest "common1.cabal"
 102     , errorTest "common2.cabal"
 103     , errorTest "common3.cabal"
 104     , errorTest "leading-comma.cabal"
 105     , errorTest "leading-comma-2.cabal"
 106     , errorTest "leading-comma-2b.cabal"
 107     , errorTest "leading-comma-2c.cabal"
 108     , errorTest "range-ge-wild.cabal"
 109     , errorTest "forward-compat.cabal"
 110     , errorTest "forward-compat2.cabal"
 111     , errorTest "forward-compat3.cabal"
 112     , errorTest "issue-5055.cabal"
 113     , errorTest "issue-5055-2.cabal"
 114     , errorTest "noVersion.cabal"
 115     , errorTest "noVersion2.cabal"
 116     , errorTest "multiple-libs.cabal"
 117     , errorTest "spdx-1.cabal"
 118     , errorTest "spdx-2.cabal"
 119     , errorTest "spdx-3.cabal"
 120     , errorTest "removed-fields.cabal"
 121     , errorTest "version-sets-1.cabal"
 122     , errorTest "version-sets-2.cabal"
 123     , errorTest "version-sets-3.cabal"
 124     , errorTest "version-sets-4.cabal"
 125     , errorTest "undefined-flag.cabal"
 126     , errorTest "mixin-1.cabal"
 127     , errorTest "mixin-2.cabal"
 128     , errorTest "libpq1.cabal"
 129     , errorTest "libpq2.cabal"
 130     , errorTest "MiniAgda.cabal"
 131     , errorTest "big-version.cabal"
 132     , errorTest "anynone.cabal"
 133     ]
 134
 135 errorTest :: FilePath -> TestTree
 136 errorTest fp = cabalGoldenTest fp correct $ do
 137     contents <- BS.readFile input
 138     let res =  parseGenericPackageDescription contents
 139     let (_, x) = runParseResult res
 140
 141     return $ toUTF8BS $ case x of
 142         Right gpd ->
 143             "UNXPECTED SUCCESS\n" ++
 144             showGenericPackageDescription gpd
 145         Left (v, errs) ->
 146             unlines $ ("VERSION: " ++ show v) : map (showPError fp) (NE.toList errs)
 147   where
 148     input = "tests" </> "ParserTests" </> "errors" </> fp
 149     correct = replaceExtension input "errors"
 150
 151 -------------------------------------------------------------------------------
 152 -- Regressions
 153 -------------------------------------------------------------------------------
 154
 155 regressionTests :: TestTree
 156 regressionTests = testGroup "regressions"
 157     [ regressionTest "encoding-0.8.cabal"
 158     , regressionTest "Octree-0.5.cabal"
 159     , regressionTest "nothing-unicode.cabal"
 160     , regressionTest "multiple-libs-2.cabal"
 161     , regressionTest "issue-774.cabal"
 162     , regressionTest "generics-sop.cabal"
 163     , regressionTest "elif.cabal"
 164     , regressionTest "elif2.cabal"
 165     , regressionTest "shake.cabal"
 166     , regressionTest "common.cabal"
 167     , regressionTest "common2.cabal"
 168     , regressionTest "common3.cabal"
 169     , regressionTest "common-conditional.cabal"
 170     , regressionTest "leading-comma.cabal"
 171     , regressionTest "leading-comma-2.cabal"
 172     , regressionTest "wl-pprint-indef.cabal"
 173     , regressionTest "th-lift-instances.cabal"
 174     , regressionTest "issue-5055.cabal"
 175     , regressionTest "issue-6083-pkg-pkg.cabal"
 176     , regressionTest "issue-6083-a.cabal"
 177     , regressionTest "issue-6083-b.cabal"
 178     , regressionTest "issue-6083-c.cabal"
 179     , regressionTest "noVersion.cabal"
 180     , regressionTest "spdx-1.cabal"
 181     , regressionTest "spdx-2.cabal"
 182     , regressionTest "spdx-3.cabal"
 183     , regressionTest "hidden-main-lib.cabal"
 184     , regressionTest "jaeger-flamegraph.cabal"
 185     , regressionTest "version-sets.cabal"
 186     , regressionTest "mixin-1.cabal"
 187     , regressionTest "mixin-2.cabal"
 188     , regressionTest "mixin-3.cabal"
 189     , regressionTest "libpq1.cabal"
 190     , regressionTest "libpq2.cabal"
 191     , regressionTest "issue-5846.cabal"
 192     , regressionTest "indentation.cabal"
 193     , regressionTest "indentation2.cabal"
 194     , regressionTest "indentation3.cabal"
 195     , regressionTest "big-version.cabal"
 196     , regressionTest "anynone.cabal"
 197     , regressionTest "monad-param.cabal"
 198     , regressionTest "hasktorch.cabal"
 199     ]
 200
 201 regressionTest :: FilePath -> TestTree
 202 regressionTest fp = testGroup fp
 203     [ formatGoldenTest fp
 204     , formatRoundTripTest fp
 205 #ifdef MIN_VERSION_tree_diff
 206     , treeDiffGoldenTest fp
 207 #endif
 208     ]
 209
 210 formatGoldenTest :: FilePath -> TestTree
 211 formatGoldenTest fp = cabalGoldenTest "format" correct $ do
 212     contents <- BS.readFile input
 213     let res = parseGenericPackageDescription contents
 214     let (warns, x) = runParseResult res
 215
 216     return $ toUTF8BS $ case x of
 217         Right gpd ->
 218             unlines (map (showPWarning fp) warns)
 219             ++ showGenericPackageDescription gpd
 220         Left (csv, errs) ->
 221             unlines $
 222                 "ERROR" :
 223                 maybe "unknown-version" prettyShow csv :
 224                 map (showPError fp) (NE.toList errs)
 225   where
 226     input = "tests" </> "ParserTests" </> "regressions" </> fp
 227     correct = replaceExtension input "format"
 228
 229 #ifdef MIN_VERSION_tree_diff
 230 treeDiffGoldenTest :: FilePath -> TestTree
 231 treeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do
 232     contents <- BS.readFile input
 233     let res =  parseGenericPackageDescription contents
 234     let (_, x) = runParseResult res
 235     case x of
 236         Right gpd      -> pure (toExpr gpd)
 237         Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPError fp) (NE.toList errs)
 238   where
 239     input = "tests" </> "ParserTests" </> "regressions" </> fp
 240     exprFile = replaceExtension input "expr"
 241 #endif
 242
 243 formatRoundTripTest :: FilePath -> TestTree
 244 formatRoundTripTest fp = testCase "roundtrip" $ do
 245     contents <- BS.readFile input
 246     x <- parse contents
 247     let contents' = showGenericPackageDescription x
 248     y <- parse (toUTF8BS contents')
 249     -- previously we mangled licenses a bit
 250     let y' = y
 251     unless (x == y') $
 252 #ifdef MIN_VERSION_tree_diff
 253         assertFailure $ unlines
 254             [ "re-parsed doesn't match"
 255             , show $ ansiWlEditExpr $ ediff x y
 256             ]
 257 #else
 258         assertFailure $ unlines
 259             [ "re-parsed doesn't match"
 260             , "expected"
 261             , show x
 262             , "actual"
 263             , show y
 264             ]
 265 #endif
 266   where
 267     parse :: BS.ByteString -> IO GenericPackageDescription
 268     parse c = do
 269         let (_, x') = runParseResult $ parseGenericPackageDescription c
 270         case x' of
 271             Right gpd      -> pure gpd
 272             Left (_, errs) -> do
 273                 void $ assertFailure $ unlines (map (showPError fp) $ NE.toList errs)
 274                 fail "failure"
 275     input = "tests" </> "ParserTests" </> "regressions" </> fp
 276
 277 -------------------------------------------------------------------------------
 278 -- InstalledPackageInfo regressions
 279 -------------------------------------------------------------------------------
 280
 281 ipiTests :: TestTree
 282 ipiTests = testGroup "ipis"
 283     [ ipiTest "transformers.cabal"
 284     , ipiTest "Includes2.cabal"
 285     , ipiTest "issue-2276-ghc-9885.cabal"
 286     , ipiTest "internal-preprocessor-test.cabal"
 287     ]
 288
 289 ipiTest :: FilePath -> TestTree
 290 ipiTest fp = testGroup fp $
 291 #ifdef MIN_VERSION_tree_diff
 292     [ ipiTreeDiffGoldenTest fp ] ++
 293 #endif
 294     [ ipiFormatGoldenTest fp
 295     , ipiFormatRoundTripTest fp
 296     ]
 297
 298 ipiFormatGoldenTest :: FilePath -> TestTree
 299 ipiFormatGoldenTest fp = cabalGoldenTest "format" correct $ do
 300     contents <- BS.readFile input
 301     let res = IPI.parseInstalledPackageInfo contents
 302     return $ toUTF8BS $ case res of
 303         Left err -> "ERROR " ++ show err
 304         Right (ws, ipi)  ->
 305             unlines ws ++ IPI.showInstalledPackageInfo ipi
 306   where
 307     input = "tests" </> "ParserTests" </> "ipi" </> fp
 308     correct = replaceExtension input "format"
 309
 310 #ifdef MIN_VERSION_tree_diff
 311 ipiTreeDiffGoldenTest :: FilePath -> TestTree
 312 ipiTreeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do
 313     contents <- BS.readFile input
 314     let res = IPI.parseInstalledPackageInfo contents
 315     case res of
 316         Left err -> fail $ "ERROR " ++ show err
 317         Right (_ws, ipi) -> pure (toExpr ipi)
 318   where
 319     input = "tests" </> "ParserTests" </> "ipi" </> fp
 320     exprFile = replaceExtension input "expr"
 321 #endif
 322
 323 ipiFormatRoundTripTest :: FilePath -> TestTree
 324 ipiFormatRoundTripTest fp = testCase "roundtrip" $ do
 325     contents <- BS.readFile input
 326     x <- parse contents
 327     let contents' = IPI.showInstalledPackageInfo x
 328     y <- parse (toUTF8BS contents')
 329
 330     -- ghc-pkg prints pkgroot itself, based on cli arguments!
 331     let x' = x { IPI.pkgRoot = Nothing }
 332     let y' = y
 333     assertBool "pkgRoot isn't shown" (isNothing (IPI.pkgRoot y))
 334     assertEqual "re-parsed doesn't match" x' y'
 335
 336     -- Complete round-trip
 337     let contents2 = IPI.showFullInstalledPackageInfo x
 338     z <- parse (toUTF8BS contents2)
 339     assertEqual "re-parsed doesn't match" x z
 340
 341   where
 342     parse :: BS.ByteString -> IO IPI.InstalledPackageInfo
 343     parse c = do
 344         case IPI.parseInstalledPackageInfo c of
 345             Right (_, ipi) -> return ipi
 346             Left err       -> do
 347               void $ assertFailure $ show err
 348               fail "failure"
 349     input = "tests" </> "ParserTests" </> "ipi" </> fp
 350
 351 -------------------------------------------------------------------------------
 352 -- Main
 353 -------------------------------------------------------------------------------
 354
 355 main :: IO ()
 356 main = do
 357     args <- getArgs
 358     case args of
 359         ("--cwd" : cwd : args') -> do
 360             setCurrentDirectory cwd
 361             withArgs args' $ defaultMain tests
 362         _ -> defaultMain tests
 363
 364 cabalGoldenTest :: TestName -> FilePath -> IO BS.ByteString -> TestTree
 365 cabalGoldenTest name ref act = goldenTest name (BS.readFile ref) act cmp upd
 366   where
 367     upd = BS.writeFile ref
 368     cmp x y | x == y = return Nothing
 369     cmp x y = return $ Just $ unlines $
 370         concatMap f (getGroupedDiff (BS8.lines x) (BS8.lines y))
 371       where
 372         f (First xs)  = map (cons3 '-' . fromUTF8BS) xs
 373         f (Second ys) = map (cons3 '+' . fromUTF8BS) ys
 374         -- we print unchanged lines too. It shouldn't be a problem while we have
 375         -- reasonably small examples
 376         f (Both xs _) = map (cons3 ' ' . fromUTF8BS) xs
 377         -- we add three characters, so the changed lines are easier to spot
 378         cons3 c cs = c : c : c : ' ' : cs