update jinja2 per CVE-2024-34064
[cabal.git] / Cabal-tests / tests / ParserTests.hs
blob981be3b4ccea7acd278c729fac9949999ef65757
1 {-# LANGUAGE CPP #-}
2 module Main
3 ( main
4 ) where
6 import Prelude ()
7 import Prelude.Compat
9 import Test.Tasty
10 import Test.Tasty.Golden.Advanced (goldenTest)
11 import Test.Tasty.HUnit
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, (</>))
27 import qualified Data.ByteString as BS
28 import qualified Data.ByteString.Char8 as BS8
29 import qualified Data.List.NonEmpty as NE
31 import qualified Distribution.InstalledPackageInfo as IPI
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
39 tests :: TestTree
40 tests = testGroup "parsec tests"
41 [ regressionTests
42 , warningTests
43 , errorTests
44 , ipiTests
47 -------------------------------------------------------------------------------
48 -- Warnings
49 -------------------------------------------------------------------------------
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"
78 warningTest :: PWarnType -> FilePath -> TestTree
79 warningTest wt fp = testCase (show wt) $ do
80 contents <- BS.readFile $ "tests" </> "ParserTests" </> "warnings" </> fp
82 let res = parseGenericPackageDescription contents
83 let (warns, x) = runParseResult res
85 assertBool ("should parse successfully: " ++ show x) $ isRight x
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
95 -------------------------------------------------------------------------------
96 -- Errors
97 -------------------------------------------------------------------------------
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"
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
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"
151 -------------------------------------------------------------------------------
152 -- Regressions
153 -------------------------------------------------------------------------------
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"
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
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
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"
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
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
257 #else
258 assertFailure $ unlines
259 [ "re-parsed doesn't match"
260 , "expected"
261 , show x
262 , "actual"
263 , show y
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
277 -------------------------------------------------------------------------------
278 -- InstalledPackageInfo regressions
279 -------------------------------------------------------------------------------
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"
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
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"
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
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')
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'
336 -- Complete round-trip
337 let contents2 = IPI.showFullInstalledPackageInfo x
338 z <- parse (toUTF8BS contents2)
339 assertEqual "re-parsed doesn't match" x z
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
351 -------------------------------------------------------------------------------
352 -- Main
353 -------------------------------------------------------------------------------
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
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