Unverified Commit e9b0a715 authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub
Browse files

Merge pull request #6586 from phadej/more-checks-in-version-range-parser

More checks in version range parser
parents 3d93cdd7 2afbd0e1
......@@ -246,6 +246,7 @@ extra-source-files:
tests/ParserTests/warnings/nbsp.cabal
tests/ParserTests/warnings/newsyntax.cabal
tests/ParserTests/warnings/oldsyntax.cabal
tests/ParserTests/warnings/operator.cabal
tests/ParserTests/warnings/subsection.cabal
tests/ParserTests/warnings/tab.cabal
tests/ParserTests/warnings/trailingfield.cabal
......@@ -253,6 +254,7 @@ extra-source-files:
tests/ParserTests/warnings/unknownsection.cabal
tests/ParserTests/warnings/utf8.cabal
tests/ParserTests/warnings/versiontag.cabal
tests/ParserTests/warnings/wildcard.cabal
tests/cbits/rpmvercmp.c
tests/hackage/check.sh
tests/hackage/download.sh
......@@ -760,6 +762,7 @@ test-suite hackage-tests
build-depends:
base-compat >=0.11.0 && <0.12,
base-orphans >=0.6 && <0.9,
clock >=0.8 && <0.9,
optparse-applicative >=0.13.2.0 && <0.16,
stm >=2.4.5.0 && <2.6,
tar >=0.5.0.3 && <0.6
......
......@@ -1253,40 +1253,6 @@ checkCabalVersion pkg =
++ "the 'other-extensions' field lists extensions that are used in "
++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."
-- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax
, checkVersion [1,8] (not (null versionRangeExpressions)) $
PackageDistInexcusable $
"The package uses full version-range expressions "
++ "in a 'build-depends' field: "
++ commaSep (map displayRawDependency versionRangeExpressions)
++ ". To use this new syntax the package needs to specify at least "
++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility "
++ "is important, then convert to conjunctive normal form, and use "
++ "multiple 'build-depends:' lines, one conjunct per line."
-- check use of "build-depends: foo == 1.*" syntax
, checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $
PackageDistInexcusable $
"The package uses wildcard syntax in the 'build-depends' field: "
++ commaSep (map prettyShow depsUsingWildcardSyntax)
++ ". To use this new syntax the package need to specify at least "
++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility "
++ "is important then use: " ++ commaSep
[ prettyShow (Dependency name (eliminateWildcardSyntax versionRange) Set.empty)
| Dependency name versionRange _ <- depsUsingWildcardSyntax ]
-- check use of "build-depends: foo ^>= 1.2.3" syntax
, checkVersion [2,0] (not (null depsUsingMajorBoundSyntax)) $
PackageDistInexcusable $
"The package uses major bounded version syntax in the "
++ "'build-depends' field: "
++ commaSep (map prettyShow depsUsingMajorBoundSyntax)
++ ". To use this new syntax the package need to specify at least "
++ "'cabal-version: 2.0'. Alternatively, if broader compatibility "
++ "is important then use: " ++ commaSep
[ prettyShow (Dependency name (eliminateMajorBoundSyntax versionRange) Set.empty)
| Dependency name versionRange _ <- depsUsingMajorBoundSyntax ]
, checkVersion [3,0] (any (not . null)
(concatMap buildInfoField
[ asmSources
......@@ -1312,26 +1278,6 @@ checkCabalVersion pkg =
"The use of 'virtual-modules' requires the package "
++ " to specify at least 'cabal-version: >= 2.1'."
-- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax
, checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $
PackageDistInexcusable $
"The package uses full version-range expressions "
++ "in a 'tested-with' field: "
++ commaSep (map displayRawDependency testedWithVersionRangeExpressions)
++ ". To use this new syntax the package needs to specify at least "
++ "'cabal-version: >= 1.8'."
-- check use of "tested-with: GHC == 6.12.*" syntax
, checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $
PackageDistInexcusable $
"The package uses wildcard syntax in the 'tested-with' field: "
++ commaSep (map prettyShow testedWithUsingWildcardSyntax)
++ ". To use this new syntax the package need to specify at least "
++ "'cabal-version: >= 1.6'. Alternatively, if broader compatibility "
++ "is important then use: " ++ commaSep
[ prettyShow (Dependency name (eliminateWildcardSyntax versionRange) Set.empty)
| Dependency name versionRange _ <- testedWithUsingWildcardSyntax ]
-- check use of "source-repository" section
, checkVersion [1,6] (not (null (sourceRepos pkg))) $
PackageDistInexcusable $
......@@ -1403,15 +1349,6 @@ checkCabalVersion pkg =
buildInfoField field = map field (allBuildInfo pkg)
versionRangeExpressions =
[ dep | dep@(Dependency _ vr _) <- allBuildDepends pkg
, usesNewVersionRangeSyntax vr ]
testedWithVersionRangeExpressions =
[ Dependency (mkPackageName (prettyShow compiler)) vr Set.empty
| (compiler, vr) <- testedWith pkg
, usesNewVersionRangeSyntax vr ]
simpleSpecVersionRangeSyntax =
either (const True) (cataVersionRange alg) (specVersionRaw pkg)
where
......@@ -1422,63 +1359,8 @@ checkCabalVersion pkg =
simpleSpecVersionSyntax =
either (const True) (const False) (specVersionRaw pkg)
usesNewVersionRangeSyntax :: VersionRange -> Bool
usesNewVersionRangeSyntax
= (> 2) -- uses the new syntax if depth is more than 2
. cataVersionRange alg
where
alg (UnionVersionRangesF a b) = a + b
alg (IntersectVersionRangesF a b) = a + b
alg (VersionRangeParensF _) = 3
alg _ = 1 :: Int
depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr _) <- allBuildDepends pkg
, usesWildcardSyntax vr ]
depsUsingMajorBoundSyntax = [ dep | dep@(Dependency _ vr _) <- allBuildDepends pkg
, usesMajorBoundSyntax vr ]
usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg)
testedWithUsingWildcardSyntax =
[ Dependency (mkPackageName (prettyShow compiler)) vr Set.empty
| (compiler, vr) <- testedWith pkg
, usesWildcardSyntax vr ]
usesWildcardSyntax :: VersionRange -> Bool
usesWildcardSyntax = cataVersionRange alg
where
alg (WildcardVersionF _) = True
alg (UnionVersionRangesF a b) = a || b
alg (IntersectVersionRangesF a b) = a || b
alg (VersionRangeParensF a) = a
alg _ = False
-- NB: this eliminates both, WildcardVersion and MajorBoundVersion
-- because when WildcardVersion is not support, neither is MajorBoundVersion
eliminateWildcardSyntax = hyloVersionRange embed projectVersionRange
where
embed (WildcardVersionF v) = intersectVersionRanges
(orLaterVersion v) (earlierVersion (wildcardUpperBound v))
embed (MajorBoundVersionF v) = intersectVersionRanges
(orLaterVersion v) (earlierVersion (majorUpperBound v))
embed vr = embedVersionRange vr
usesMajorBoundSyntax :: VersionRange -> Bool
usesMajorBoundSyntax = cataVersionRange alg
where
alg (MajorBoundVersionF _) = True
alg (UnionVersionRangesF a b) = a || b
alg (IntersectVersionRangesF a b) = a || b
alg (VersionRangeParensF a) = a
alg _ = False
eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange
where
embed (MajorBoundVersionF v) = intersectVersionRanges
(orLaterVersion v) (earlierVersion (majorUpperBound v))
embed vr = embedVersionRange vr
mentionedExtensions = [ ext | bi <- allBuildInfo pkg
, ext <- allExtensions bi ]
mentionedExtensionsThatNeedCabal12 =
......@@ -1529,11 +1411,6 @@ checkCabalVersion pkg =
allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg)
displayRawDependency :: Dependency -> String
displayRawDependency (Dependency pkg vr _sublibs) =
prettyShow pkg ++ " " ++ prettyShow vr
-- ------------------------------------------------------------
-- * Checks on the GenericPackageDescription
-- ------------------------------------------------------------
......
......@@ -9,9 +9,12 @@ module Distribution.Parsec (
runParsecParser,
runParsecParser',
simpleParsec,
simpleParsec',
simpleParsecW',
lexemeParsec,
eitherParsec,
explicitEitherParsec,
explicitEitherParsec',
-- * CabalParsing and and diagnostics
CabalParsing (..),
-- ** Warnings
......@@ -171,6 +174,25 @@ simpleParsec
. runParsecParser lexemeParsec "<simpleParsec>"
. fieldLineStreamFromString
-- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'.
--
-- @since 3.4.0.0
simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a
simpleParsec' spec
= either (const Nothing) Just
. runParsecParser' spec lexemeParsec "<simpleParsec>"
. fieldLineStreamFromString
-- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'.
-- Fail if there are any warnings.
--
-- @since 3.4.0.0
simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a
simpleParsecW' spec
= either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing)
. runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "<simpleParsec>"
. fieldLineStreamFromString
-- | Parse a 'String' with 'lexemeParsec'.
eitherParsec :: Parsec a => String -> Either String a
eitherParsec = explicitEitherParsec parsec
......@@ -182,6 +204,17 @@ explicitEitherParsec parser
. runParsecParser (parser <* P.spaces) "<eitherParsec>"
. fieldLineStreamFromString
-- | Parse a 'String' with given 'ParsecParser' and 'CabalSpecVersion'. Trailing whitespace is accepted.
-- See 'explicitEitherParsec'.
--
-- @since 3.4.0.0
--
explicitEitherParsec' :: CabalSpecVersion -> ParsecParser a -> String -> Either String a
explicitEitherParsec' spec parser
= either (Left . show) Right
. runParsecParser' spec (parser <* P.spaces) "<eitherParsec>"
. fieldLineStreamFromString
-- | Run 'ParsecParser' with 'cabalSpecLatest'.
runParsecParser :: ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a
runParsecParser = runParsecParser' cabalSpecLatest
......
......@@ -35,6 +35,9 @@ data PWarnType
| PWTDoubleDash -- ^ Double dash token, most likely it's a mistake - it's not a comment
| PWTMultipleSingularField -- ^ e.g. name or version should be specified only once.
| PWTBuildTypeDefault -- ^ Workaround for derive-package having build-type: Default. See <https://github.com/haskell/cabal/issues/5020>.
| PWTVersionOperator -- ^ Version operators used (without cabal-version: 1.8)
| PWTVersionWildcard -- ^ Version wildcard used (without cabal-version: 1.6)
deriving (Eq, Ord, Show, Enum, Bounded, Generic)
instance Binary PWarnType
......
......@@ -69,7 +69,7 @@ instance Parsec PkgconfigVersionRange where
csv <- askCabalSpecVersion
if csv >= CabalSpecV3_0
then pkgconfigParser
else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral
else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv
-- "modern" parser of @pkg-config@ package versions.
pkgconfigParser :: CabalParsing m => m PkgconfigVersionRange
......
......@@ -262,8 +262,40 @@ instance Pretty VersionRange where
punct p p' | p < p' = Disp.parens
| otherwise = id
-- |
--
-- >>> simpleParsec "^>= 3.4" :: Maybe VersionRange
-- Just (MajorBoundVersion (mkVersion [3,4]))
--
-- Small history:
--
-- Set operations are introduced in 3.0
--
-- >>> map (`simpleParsec'` "^>= { 1.2 , 1.3 }") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe VersionRange]
-- [Nothing,Just (UnionVersionRanges (MajorBoundVersion (mkVersion [1,2])) (MajorBoundVersion (mkVersion [1,3])))]
--
-- @^>=@ is introduced in 2.0
--
-- >>> map (`simpleParsec'` "^>=1.2") [CabalSpecV1_24, CabalSpecV2_0] :: [Maybe VersionRange]
-- [Nothing,Just (MajorBoundVersion (mkVersion [1,2]))]
--
-- @-none@ is introduced in 1.22
--
-- >>> map (`simpleParsec'` "-none") [CabalSpecV1_20, CabalSpecV1_22] :: [Maybe VersionRange]
-- [Nothing,Just (IntersectVersionRanges (LaterVersion (mkVersion [1])) (EarlierVersion (mkVersion [1])))]
--
-- Operators are introduced in 1.8. Issues only a warning.
--
-- >>> map (`simpleParsecW'` "== 1 || ==2") [CabalSpecV1_6, CabalSpecV1_8] :: [Maybe VersionRange]
-- [Nothing,Just (UnionVersionRanges (ThisVersion (mkVersion [1])) (ThisVersion (mkVersion [2])))]
--
-- Wild-version ranges are introduced in 1.6. Issues only a warning.
--
-- >>> map (`simpleParsecW'` "== 1.2.*") [CabalSpecV1_4, CabalSpecV1_6] :: [Maybe VersionRange]
-- [Nothing,Just (WildcardVersion (mkVersion [1,2]))]
--
instance Parsec VersionRange where
parsec = versionRangeParser versionDigitParser
parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser
instance Described VersionRange where
describe _ = RERec "version-range" $ REUnion
......@@ -301,13 +333,14 @@ instance Described VersionRange where
-- versions, 'PkgConfigVersionRange'.
--
-- @since 3.0
versionRangeParser :: forall m. CabalParsing m => m Int -> m VersionRange
versionRangeParser digitParser = expr
versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange
versionRangeParser digitParser csv = expr
where
expr = do P.spaces
t <- term
P.spaces
(do _ <- P.string "||"
checkOp
P.spaces
e <- expr
return (unionVersionRanges t e)
......@@ -316,6 +349,7 @@ versionRangeParser digitParser = expr
term = do f <- factor
P.spaces
(do _ <- P.string "&&"
checkOp
P.spaces
t <- term
return (intersectVersionRanges f t)
......@@ -331,6 +365,7 @@ versionRangeParser digitParser = expr
"==" -> do
P.spaces
(do (wild, v) <- verOrWild
checkWild wild
pure $ (if wild then withinVersion else thisVersion) v
<|>
(verSet' thisVersion =<< verSet))
......@@ -356,6 +391,27 @@ versionRangeParser digitParser = expr
">" -> pure $ laterVersion v
_ -> fail $ "Unknown version operator " ++ show op
-- Cannot be warning
-- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this
-- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal
--
checkOp = when (csv < CabalSpecV1_8) $
parsecWarning PWTVersionOperator $ unwords
[ "version operators used."
, "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'."
]
-- Cannot be warning
-- On 2020-03-16 there was 46 files on Hackage failing to parse due this
-- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal
--
checkWild False = pure ()
checkWild True = when (csv < CabalSpecV1_6) $
parsecWarning PWTVersionWildcard $ unwords
[ "Wildcard syntax used."
, "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'."
]
-- https://gitlab.haskell.org/ghc/ghc/issues/17752
isOpChar '<' = True
isOpChar '=' = True
......@@ -364,13 +420,8 @@ versionRangeParser digitParser = expr
isOpChar '-' = True
isOpChar _ = False
-- Note: There are other features:
-- && and || since 1.8
-- x.y.* (wildcard) since 1.6
-- -none version range is available since 1.22
noVersion' = do
csv <- askCabalSpecVersion
noVersion' =
if csv >= CabalSpecV1_22
then pure noVersion
else fail $ unwords
......@@ -381,8 +432,7 @@ versionRangeParser digitParser = expr
]
-- ^>= is available since 2.0
majorBoundVersion' v = do
csv <- askCabalSpecVersion
majorBoundVersion' v =
if csv >= CabalSpecV2_0
then pure $ majorBoundVersion v
else fail $ unwords
......@@ -398,8 +448,7 @@ versionRangeParser digitParser = expr
embed vr = embedVersionRange vr
-- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }")
verSet' op vs = do
csv <- askCabalSpecVersion
verSet' op vs =
if csv >= CabalSpecV3_0
then pure $ foldr1 unionVersionRanges (fmap op vs)
else fail $ unwords
......
......@@ -6,25 +6,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
#endif
-- | The following RTS parameters seem to speed up running the test
--
-- @
-- +RTS -s -qg -I0 -A64M -N2 -RTS
-- @
--
-- * @-qg@ No parallel GC (you can try @-qn2@ on GHC-8.2+)
-- * @-I0@ No idle GC (shouldn't matter, but to be sure)
-- * @-A64M@ Set allocation area to about the maximum residence size tests have
-- * @-N4@ More capabilities (depends on your machine)
--
-- @-N1@ vs. @-N4@ gives
--
-- * @1m 48s@ to @1m 00s@ speedup for full Hackage @parsec@ test, and
--
-- * @6m 16s@ to @3m 30s@ speedup for full Hackage @roundtrip@ test.
--
-- i.e. not linear, but substantial improvement anyway.
--
module Main where
import Distribution.Compat.Semigroup
......@@ -32,23 +13,18 @@ import Prelude ()
import Prelude.Compat
import Control.Applicative (many, (<**>), (<|>))
import Control.Concurrent
(ThreadId, forkIO, getNumCapabilities, killThread, myThreadId, throwTo)
import Control.Concurrent.STM
import Control.DeepSeq (NFData (..), force)
import Control.Exception
(AsyncException (ThreadKilled), SomeException, bracket, catch, evaluate, fromException,
mask, throwIO)
import Control.Monad (forever, join, replicateM, unless, when)
import Data.Foldable (for_, traverse_)
import Data.IORef (modifyIORef', newIORef, readIORef)
import Control.Exception (evaluate)
import Control.Monad (join, unless, when)
import Data.Foldable (traverse_)
import Data.List (isPrefixOf, isSuffixOf)
import Data.Maybe (mapMaybe)
import Data.Monoid (Sum (..))
import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage)
import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
import Distribution.PackageDescription.Quirks (patchQuirks)
import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS, fromUTF8BS)
import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)
import Numeric (showFFloat)
import System.Directory (getAppUserDataDirectory)
import System.Environment (lookupEnv)
import System.Exit (exitFailure)
......@@ -64,11 +40,12 @@ import qualified Distribution.Fields.Parser as Parsec
import qualified Distribution.Fields.Pretty as PP
import qualified Distribution.PackageDescription.Parsec as Parsec
import qualified Distribution.Parsec as Parsec
import qualified Options.Applicative as O
import qualified System.Clock as Clock
import Distribution.Compat.Lens
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import qualified Distribution.Types.PackageDescription.Lens as L
import qualified Options.Applicative as O
-- import Distribution.Types.BuildInfo (BuildInfo (cppOptions))
-- import qualified Distribution.Types.BuildInfo.Lens as L
......@@ -102,7 +79,7 @@ parseIndex predicate action = do
case mx of
Just x -> return x
Nothing -> return (cabalDir </> "config")
parseIndex'
:: (Monoid a, NFData a)
......@@ -152,15 +129,37 @@ readFieldTest fpath bs = case Parsec.readFields bs' of
-- Parsec test: whether we can parse everything
-------------------------------------------------------------------------------
parseParsecTest :: FilePath -> B.ByteString -> IO (Sum Int)
parseParsecTest fpath bs = do
let (_warnings, parsec) = Parsec.runParseResult $
parseParsecTest :: Bool -> FilePath -> B.ByteString -> IO ThreeInt
parseParsecTest keepGoing fpath bs = do
let (warnings, parsec) = Parsec.runParseResult $
Parsec.parseGenericPackageDescription bs
let w | null warnings = 0
| otherwise = 1
case parsec of
Right _ -> return (Sum 1)
Left (_, errors) -> do
traverse_ (putStrLn . Parsec.showPError fpath) errors
exitFailure
Right _ -> return (ThreeInt 1 w 0)
Left (_, errors) | keepGoing -> return (ThreeInt 1 w 1)
| otherwise -> do
traverse_ (putStrLn . Parsec.showPError fpath) errors
exitFailure
-------------------------------------------------------------------------------
-- ThreeInt
-------------------------------------------------------------------------------
data ThreeInt = ThreeInt !Int !Int !Int
deriving (Eq, Show)
instance Semigroup ThreeInt where
ThreeInt x y z <> ThreeInt u v w = ThreeInt (x + u) (y + v) (z + w)
instance Monoid ThreeInt where
mempty = ThreeInt 0 0 0
mappend = (<>)
instance NFData ThreeInt where
rnf (ThreeInt _ _ _) = ()
-------------------------------------------------------------------------------
-- Check test
......@@ -178,9 +177,9 @@ parseCheckTest fpath bs = do
-- Look into invalid cpp options
-- _ <- L.traverseBuildInfos checkCppFlags gpd
-- one for file, many checks
return (CheckResult 1 (w warnings) 0 0 0 0 0 <> foldMap toCheckResult checks)
return (CheckResult 1 (w warnings) 0 0 0 0 0 0 <> foldMap toCheckResult checks)
Left (_, errors) -> do
traverse_ (putStrLn . Parsec.showPError fpath) errors
exitFailure
......@@ -190,28 +189,28 @@ parseCheckTest fpath bs = do
-- for_ (cppOptions bi) $ \opt ->
-- unless (any (`isPrefixOf` opt) ["-D", "-U", "-I"]) $
-- putStrLn opt
--
--
-- return bi
data CheckResult = CheckResult !Int !Int !Int !Int !Int !Int !Int
data CheckResult = CheckResult !Int !Int !Int !Int !Int !Int !Int !Int
instance NFData CheckResult where
rnf !_ = ()
instance Semigroup CheckResult where
CheckResult n w a b c d e <> CheckResult n' w' a' b' c' d' e' =
CheckResult (n + n') (w + w') (a + a') (b + b') (c + c') (d + d') (e + e')
CheckResult n w a b c d e f <> CheckResult n' w' a' b' c' d' e' f' =
CheckResult (n + n') (w + w') (a + a') (b + b') (c + c') (d + d') (e + e') (f + f')
instance Monoid CheckResult where
mempty = CheckResult 0 0 0 0 0 0 0
mempty = CheckResult 0 0 0 0 0 0 0 0
mappend = (<>)
toCheckResult :: PackageCheck -> CheckResult
toCheckResult PackageBuildImpossible {} = CheckResult 0 0 1 0 0 0 0
toCheckResult PackageBuildWarning {} = CheckResult 0 0 0 1 0 0 0
toCheckResult PackageDistSuspicious {} = CheckResult 0 0 0 0 1 0 0
toCheckResult PackageDistSuspiciousWarn {} = CheckResult 0 0 0 0 0 1 0
toCheckResult PackageDistInexcusable {} = CheckResult 0 0 0 0 0 0 1
toCheckResult PackageBuildImpossible {} = CheckResult 0 0 1 1 0 0 0 0
toCheckResult PackageBuildWarning {} = CheckResult 0 0 1 0 1 0 0 0
toCheckResult PackageDistSuspicious {} = CheckResult 0 0 1 0 0 1 0 0
toCheckResult PackageDistSuspiciousWarn {} = CheckResult 0 0 1 0 0 0 1 0
toCheckResult PackageDistInexcusable {} = CheckResult 0 0 1 0 0 0 0 1
-------------------------------------------------------------------------------
-- Roundtrip test
......@@ -313,15 +312,27 @@ main = join (O.execParser opts)
defaultA = do
putStrLn "Default action: parsec k"
parsecA (mkPredicate ["k"])
parsecA (mkPredicate ["k"]) False
readFieldsP = readFieldsA <$> prefixP
readFieldsA pfx = parseIndex pfx readFieldTest
parsecP = parsecA <$> prefixP
parsecA pfx = do
Sum n <- parseIndex pfx parseParsecTest
parsecP = parsecA <$> prefixP <*> keepGoingP
keepGoingP =
O.flag' True (O.long "keep-going") <|>
O.flag' False (O.long "no-keep-going") <|>
pure False
parsecA pfx keepGoing = do
begin <- Clock.getTime Clock.Monotonic
ThreeInt n w f <- parseIndex pfx (parseParsecTest keepGoing)
end <- Clock.getTime Clock.Monotonic
let diff = Clock.toNanoSecs $ Clock.diffTimeSpec end begin
putStrLn $ show n ++ " files processed"
putStrLn $ show w ++ " files contained warnings"
putStrLn $ show f ++ " files failed to parse"
putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e9 :: Double) " seconds elapsed"
roundtripP = roundtripA <$> prefixP <*> testFieldsP
roundtripA pfx testFieldsTransform = do
......@@ -330,9 +341,10 @@ main = join (O.execParser opts)
checkP = checkA <$> prefixP
checkA pfx = do
CheckResult n w a b c d e <- parseIndex pfx parseCheckTest
CheckResult n w x a b c d e <- parseIndex pfx parseCheckTest
putStrLn $ show n ++ " files processed"
putStrLn $ show w ++ " have lexer/parser warnings"