Skip to content

Commit af651ab

Browse files
phadejphadej
authored
Merge pull request #6854 from phadej/issue-6853
Fix #6583: Use more lenient flag assignment parser in D.S.Setup
2 parents 343b524 + d2b58ca commit af651ab

File tree

6 files changed

+89
-52
lines changed

6 files changed

+89
-52
lines changed

‎Cabal/Distribution/Pretty.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,10 @@ class Pretty a where
2424
prettyVersioned :: CabalSpecVersion -> a -> PP.Doc
2525
prettyVersioned _ = pretty
2626

27+
-- | @since 3.4.0.0
28+
instance Pretty PP.Doc where
29+
pretty = id
30+
2731
instance Pretty Bool where
2832
pretty = PP.text . show
2933

‎Cabal/Distribution/Simple/Setup.hs

Lines changed: 3 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -99,6 +99,7 @@ import Distribution.Simple.InstallDirs
9999
import Distribution.Verbosity
100100
import Distribution.Utils.NubList
101101
import Distribution.Types.ComponentId
102+
import Distribution.Types.Flag
102103
import Distribution.Types.GivenComponent
103104
import Distribution.Types.Module
104105
import Distribution.Types.PackageName
@@ -609,8 +610,8 @@ configureOptions showOrParseArgs =
609610
"Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false."
610611
configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v })
611612
(reqArg "FLAGS"
612-
(parsecToReadE (\err -> "Invalid flag assignment: " ++ err) parsecFlagAssignment)
613-
showFlagAssignment)
613+
(parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment)
614+
legacyShowFlagAssignment')
614615

615616
,option "" ["extra-include-dirs"]
616617
"A list of directories to search for header files"
@@ -725,16 +726,6 @@ configureOptions showOrParseArgs =
725726
reqArgFlag title _sf _lf d
726727
(fmap fromPathTemplate . get) (set . fmap toPathTemplate)
727728

728-
showFlagAssignment :: FlagAssignment -> [String]
729-
showFlagAssignment = map showFlagValue' . unFlagAssignment
730-
where
731-
-- We can't use 'showFlagValue' because legacy custom-setups don't
732-
-- support the '+' prefix in --flags; so we omit the (redundant) + prefix;
733-
-- NB: we assume that we never have to set/enable '-'-prefixed flags here.
734-
showFlagValue' :: (FlagName, Bool) -> String
735-
showFlagValue' (f, True) = unFlagName f
736-
showFlagValue' (f, False) = '-' : unFlagName f
737-
738729
readPackageDbList :: String -> [Maybe PackageDB]
739730
readPackageDbList "clear" = [Nothing]
740731
readPackageDbList "global" = [Just GlobalPackageDB]

‎Cabal/Distribution/Types/Flag.hs

Lines changed: 49 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,11 +2,14 @@
22
{-# LANGUAGE DeriveGeneric #-}
33
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
44
module Distribution.Types.Flag (
5+
-- * Package flag
56
PackageFlag(..),
67
emptyFlag,
8+
-- * Flag name
79
FlagName,
810
mkFlagName,
911
unFlagName,
12+
-- * Flag assignment
1013
FlagAssignment,
1114
mkFlagAssignment,
1215
unFlagAssignment,
@@ -17,8 +20,13 @@ module Distribution.Types.Flag (
1720
nullFlagAssignment,
1821
showFlagValue,
1922
dispFlagAssignment,
23+
showFlagAssignment,
2024
parsecFlagAssignment,
2125
parsecFlagAssignmentNonEmpty,
26+
-- ** Legacy formats
27+
legacyShowFlagAssignment,
28+
legacyShowFlagAssignment',
29+
legacyParsecFlagAssignment,
2230
) where
2331

2432
import Prelude ()
@@ -294,4 +302,45 @@ parsecFlagAssignmentNonEmpty = mkFlagAssignment . toList <$>
294302
f <- parsec
295303
return (f, False)
296304

305+
-- | Show flag assignment.
306+
--
307+
-- @since 3.4.0.0
308+
showFlagAssignment :: FlagAssignment -> String
309+
showFlagAssignment = prettyShow . dispFlagAssignment
310+
311+
-------------------------------------------------------------------------------
312+
-- Legacy: without requiring +
313+
-------------------------------------------------------------------------------
314+
315+
-- | We need this as far as we support custom setups older than 2.2.0.0
316+
--
317+
-- @since 3.4.0.0
318+
legacyShowFlagAssignment :: FlagAssignment -> String
319+
legacyShowFlagAssignment =
320+
prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment'
297321

322+
-- | @since 3.4.0.0
323+
legacyShowFlagAssignment' :: FlagAssignment -> [String]
324+
legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment
325+
326+
-- | @since 3.4.0.0
327+
legacyShowFlagValue :: (FlagName, Bool) -> String
328+
legacyShowFlagValue (f, True) = unFlagName f
329+
legacyShowFlagValue (f, False) = '-' : unFlagName f
330+
331+
-- |
332+
-- We need this as far as we support custom setups older than 2.2.0.0
333+
--
334+
-- @since 3.4.0.0
335+
legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment
336+
legacyParsecFlagAssignment = mkFlagAssignment <$>
337+
P.sepBy (onFlag <|> offFlag) P.skipSpaces1
338+
where
339+
onFlag = do
340+
_ <- P.optional (P.char '+')
341+
f <- parsec
342+
return (f, True)
343+
offFlag = do
344+
_ <- P.char '-'
345+
f <- parsec
346+
return (f, False)

‎cabal-install/Distribution/Client/Install.hs

Lines changed: 18 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -138,9 +138,10 @@ import Distribution.Types.PackageVersionConstraint
138138
import Distribution.Types.MungedPackageId
139139
import qualified Distribution.PackageDescription as PackageDescription
140140
import Distribution.PackageDescription
141-
( PackageDescription, GenericPackageDescription(..), PackageFlag(..)
142-
, FlagAssignment, mkFlagAssignment, unFlagAssignment
143-
, showFlagValue, diffFlagAssignment, nullFlagAssignment )
141+
( PackageDescription, GenericPackageDescription(..) )
142+
import Distribution.Types.Flag
143+
( PackageFlag(..), FlagAssignment, mkFlagAssignment
144+
, showFlagAssignment, diffFlagAssignment, nullFlagAssignment )
144145
import Distribution.PackageDescription.Configuration
145146
( finalizePD )
146147
import Distribution.Version
@@ -654,24 +655,26 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
654655
showPkg (pkg, _) = prettyShow (packageId pkg) ++
655656
showLatest (pkg)
656657

657-
showPkgAndReason (ReadyPackage pkg', pr) = prettyShow (packageId pkg') ++
658-
showLatest pkg' ++
659-
showFlagAssignment (nonDefaultFlags pkg') ++
660-
showStanzas (confPkgStanzas pkg') ++
661-
showDep pkg' ++
662-
case pr of
663-
NewPackage -> " (new package)"
664-
NewVersion _ -> " (new version)"
665-
Reinstall _ cs -> " (reinstall)" ++ case cs of
658+
showPkgAndReason (ReadyPackage pkg', pr) = unwords
659+
[ prettyShow (packageId pkg')
660+
, showLatest pkg'
661+
, showFlagAssignment (nonDefaultFlags pkg')
662+
, showStanzas (confPkgStanzas pkg')
663+
, showDep pkg'
664+
, case pr of
665+
NewPackage -> "(new package)"
666+
NewVersion _ -> "(new version)"
667+
Reinstall _ cs -> "(reinstall)" ++ case cs of
666668
[] -> ""
667-
diff -> " (changes: " ++ intercalate ", " (map change diff)
669+
diff -> "(changes: " ++ intercalate ", " (map change diff)
668670
++ ")"
671+
]
669672

670673
showLatest :: Package srcpkg => srcpkg -> String
671674
showLatest pkg = case mLatestVersion of
672675
Just latestVersion ->
673676
if packageVersion pkg < latestVersion
674-
then (" (latest: " ++ prettyShow latestVersion ++ ")")
677+
then ("(latest: " ++ prettyShow latestVersion ++ ")")
675678
else ""
676679
Nothing -> ""
677680
where
@@ -694,10 +697,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
694697
in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment
695698

696699
showStanzas :: [OptionalStanza] -> String
697-
showStanzas = concatMap ((" *" ++) . showStanza)
698-
699-
showFlagAssignment :: FlagAssignment -> String
700-
showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment
700+
showStanzas = unwords . map (("*" ++) . showStanza)
701701

702702
change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed"
703703
change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> "

‎cabal-install/Distribution/Client/PackageHash.hs

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -30,8 +30,8 @@ import Distribution.Package
3030
, PkgconfigName )
3131
import Distribution.System
3232
( Platform, OS(Windows, OSX), buildOS )
33-
import Distribution.PackageDescription
34-
( FlagAssignment, unFlagAssignment, showFlagValue )
33+
import Distribution.Types.Flag
34+
( FlagAssignment, showFlagAssignment )
3535
import Distribution.Simple.Compiler
3636
( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
3737
, ProfDetailLevel(..), showProfDetailLevel )
@@ -315,5 +315,3 @@ renderPackageHashInputs PackageHashInputs{
315315
opt key def format value
316316
| value == def = Nothing
317317
| otherwise = entry key format value
318-
319-
showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment

‎cabal-install/Distribution/Client/ProjectOrchestration.hs

Lines changed: 13 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -143,9 +143,8 @@ import Distribution.Types.UnqualComponentName
143143
import Distribution.Solver.Types.OptionalStanza
144144

145145
import Distribution.Package
146-
import Distribution.PackageDescription
147-
( FlagAssignment, unFlagAssignment, showFlagValue
148-
, diffFlagAssignment )
146+
import Distribution.Types.Flag
147+
( FlagAssignment, showFlagAssignment, diffFlagAssignment )
149148
import Distribution.Simple.LocalBuildInfo
150149
( ComponentName(..), pkgComponents )
151150
import Distribution.Simple.Flag
@@ -853,21 +852,20 @@ printPlan verbosity
853852
| otherwise = "will"
854853

855854
showPkgAndReason :: ElaboratedReadyPackage -> String
856-
showPkgAndReason (ReadyPackage elab) =
857-
" - " ++
858-
(if verbosity >= deafening
855+
showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $
856+
[ " -"
857+
, if verbosity >= deafening
859858
then prettyShow (installedUnitId elab)
860859
else prettyShow (packageId elab)
861-
) ++
862-
(case elabPkgOrComp elab of
860+
, case elabPkgOrComp elab of
863861
ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg)
864862
ElabComponent comp ->
865-
" (" ++ showComp elab comp ++ ")"
866-
) ++
867-
showFlagAssignment (nonDefaultFlags elab) ++
868-
showConfigureFlags elab ++
869-
let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in
870-
" (" ++ showBuildStatus buildStatus ++ ")"
863+
"(" ++ showComp elab comp ++ ")"
864+
, showFlagAssignment (nonDefaultFlags elab)
865+
, showConfigureFlags elab
866+
, let buildStatus = pkgsBuildStatus Map.! installedUnitId elab
867+
in "(" ++ showBuildStatus buildStatus ++ ")"
868+
]
871869

872870
showComp elab comp =
873871
maybe "custom" prettyShow (compComponentName comp) ++
@@ -892,14 +890,11 @@ printPlan verbosity
892890
showTargets elab
893891
| null (elabBuildTargets elab) = ""
894892
| otherwise
895-
= " ("
893+
= "("
896894
++ intercalate ", " [ showComponentTarget (packageId elab) t
897895
| t <- elabBuildTargets elab ]
898896
++ ")"
899897

900-
showFlagAssignment :: FlagAssignment -> String
901-
showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment
902-
903898
showConfigureFlags elab =
904899
let fullConfigureFlags
905900
= setupHsConfigureFlags

0 commit comments

Comments
 (0)