Cabal-tests/tests/CheckTests.hs

   1 module Main
   2     ( main
   3     ) where
   4
   5 import Test.Tasty
   6 import Test.Tasty.Golden.Advanced (goldenTest)
   7
   8 import Data.Algorithm.Diff                    (PolyDiff (..), getGroupedDiff)
   9 import Distribution.Fields                    (runParseResult)
  10 import Distribution.PackageDescription.Check  (checkPackage)
  11 import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
  12 import Distribution.Parsec
  13 import Distribution.Utils.Generic             (fromUTF8BS, toUTF8BS)
  14 import System.Directory                       (setCurrentDirectory)
  15 import System.Environment                     (getArgs, withArgs)
  16 import System.FilePath                        (replaceExtension, (</>))
  17
  18 import qualified Data.ByteString       as BS
  19 import qualified Data.ByteString.Char8 as BS8
  20 import qualified Data.List.NonEmpty    as NE
  21
  22 tests :: TestTree
  23 tests = checkTests
  24
  25 -------------------------------------------------------------------------------
  26 -- Regressions
  27 -------------------------------------------------------------------------------
  28
  29 checkTests :: TestTree
  30 checkTests = testGroup "regressions"
  31     [ checkTest "nothing-unicode.cabal"
  32     , checkTest "haddock-api-2.18.1-check.cabal"
  33     , checkTest "issue-774.cabal"
  34     , checkTest "extensions-paths-5054.cabal"
  35     , checkTest "pre-1.6-glob.cabal"
  36     , checkTest "pre-2.4-globstar.cabal"
  37     , checkTest "bad-glob-syntax.cabal"
  38     , checkTest "globstar-literal.cabal"
  39     , checkTest "pre-3.8-globstar-literal.cabal"
  40     , checkTest "cc-options-with-optimization.cabal"
  41     , checkTest "cxx-options-with-optimization.cabal"
  42     , checkTest "ghc-option-j.cabal"
  43     , checkTest "multiple-libs-2.cabal"
  44     , checkTest "assoc-cpp-options.cabal"
  45     , checkTest "public-multilib-1.cabal"
  46     , checkTest "public-multilib-2.cabal"
  47     , checkTest "all-upper-bound.cabal"
  48     , checkTest "issue-6288-a.cabal"
  49     , checkTest "issue-6288-b.cabal"
  50     , checkTest "issue-6288-c.cabal"
  51     , checkTest "issue-6288-d.cabal"
  52     , checkTest "issue-6288-e.cabal"
  53     , checkTest "issue-6288-f.cabal"
  54     , checkTest "denormalised-paths.cabal"
  55     , checkTest "issue-7776-a.cabal"
  56     , checkTest "issue-7776-b.cabal"
  57     , checkTest "issue-7776-c.cabal"
  58     , checkTest "issue-8646.cabal"
  59     , checkTest "decreasing-indentation.cabal"
  60     ]
  61
  62 checkTest :: FilePath -> TestTree
  63 checkTest fp = cabalGoldenTest fp correct $ do
  64     contents <- BS.readFile input
  65     let res =  parseGenericPackageDescription contents
  66     let (ws, x) = runParseResult res
  67
  68     return $ toUTF8BS $ case x of
  69         Right gpd      ->
  70             -- Note: parser warnings are reported by `cabal check`, but not by
  71             -- D.PD.Check functionality.
  72             unlines (map (showPWarning fp) ws) ++
  73             unlines (map show (checkPackage gpd))
  74         Left (_, errs) -> unlines $ map (("ERROR: " ++) . showPError fp) $ NE.toList errs
  75   where
  76     input = "tests" </> "ParserTests" </> "regressions" </> fp
  77     correct = replaceExtension input "check"
  78
  79 -------------------------------------------------------------------------------
  80 -- Main
  81 -------------------------------------------------------------------------------
  82
  83 main :: IO ()
  84 main = do
  85     args <- getArgs
  86     case args of
  87         ("--cwd" : cwd : args') -> do
  88             setCurrentDirectory cwd
  89             withArgs args' $ defaultMain tests
  90         _ -> defaultMain tests
  91
  92 cabalGoldenTest :: TestName -> FilePath -> IO BS.ByteString -> TestTree
  93 cabalGoldenTest name ref act = goldenTest name (BS.readFile ref) act cmp upd
  94   where
  95     upd = BS.writeFile ref
  96     cmp x y | x == y = return Nothing
  97     cmp x y = return $ Just $ unlines $
  98         concatMap f (getGroupedDiff (BS8.lines x) (BS8.lines y))
  99       where
 100         f (First xs)  = map (cons3 '-' . fromUTF8BS) xs
 101         f (Second ys) = map (cons3 '+' . fromUTF8BS) ys
 102         -- we print unchanged lines too. It shouldn't be a problem while we have
 103         -- reasonably small examples
 104         f (Both xs _) = map (cons3 ' ' . fromUTF8BS) xs
 105         -- we add three characters, so the changed lines are easier to spot
 106         cons3 c cs = c : c : c : ' ' : cs