Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
e9b0a715
Unverified
Commit
e9b0a715
authored
Mar 16, 2020
by
Oleg Grenrus
Committed by
GitHub
Mar 16, 2020
Browse files
Merge pull request #6586 from phadej/more-checks-in-version-range-parser
More checks in version range parser
parents
3d93cdd7
2afbd0e1
Changes
25
Hide whitespace changes
Inline
Side-by-side
Cabal/Cabal.cabal
View file @
e9b0a715
...
...
@@ -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
...
...
Cabal/Distribution/PackageDescription/Check.hs
View file @
e9b0a715
...
...
@@ -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
-- ------------------------------------------------------------
...
...
Cabal/Distribution/Parsec.hs
View file @
e9b0a715
...
...
@@ -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
...
...
Cabal/Distribution/Parsec/Warning.hs
View file @
e9b0a715
...
...
@@ -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
...
...
Cabal/Distribution/Types/PkgconfigVersionRange.hs
View file @
e9b0a715
...
...
@@ -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
...
...
Cabal/Distribution/Types/VersionRange/Internal.hs
View file @
e9b0a715
...
...
@@ -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
...
...
Cabal/tests/HackageTests.hs
View file @
e9b0a715
...
...
@@ -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
Three
Int
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<