Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix #6853: Use more lenient flag assignment parser in D.S.Setup #6854

Merged
merged 1 commit into from
May 28, 2020
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 4 additions & 0 deletions Cabal/Distribution/Pretty.hs
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,10 @@ class Pretty a where
prettyVersioned :: CabalSpecVersion -> a -> PP.Doc
prettyVersioned _ = pretty

-- | @since 3.4.0.0
instance Pretty PP.Doc where
pretty = id

instance Pretty Bool where
pretty = PP.text . show

Expand Down
15 changes: 3 additions & 12 deletions Cabal/Distribution/Simple/Setup.hs
Original file line number Diff line number Diff line change
Expand Up @@ -99,6 +99,7 @@ import Distribution.Simple.InstallDirs
import Distribution.Verbosity
import Distribution.Utils.NubList
import Distribution.Types.ComponentId
import Distribution.Types.Flag
import Distribution.Types.GivenComponent
import Distribution.Types.Module
import Distribution.Types.PackageName
Expand Down Expand Up @@ -609,8 +610,8 @@ configureOptions showOrParseArgs =
"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."
configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v })
(reqArg "FLAGS"
(parsecToReadE (\err -> "Invalid flag assignment: " ++ err) parsecFlagAssignment)
showFlagAssignment)
(parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment)
legacyShowFlagAssignment')

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

showFlagAssignment :: FlagAssignment -> [String]
showFlagAssignment = map showFlagValue' . unFlagAssignment
where
-- We can't use 'showFlagValue' because legacy custom-setups don't
-- support the '+' prefix in --flags; so we omit the (redundant) + prefix;
-- NB: we assume that we never have to set/enable '-'-prefixed flags here.
showFlagValue' :: (FlagName, Bool) -> String
showFlagValue' (f, True) = unFlagName f
showFlagValue' (f, False) = '-' : unFlagName f

readPackageDbList :: String -> [Maybe PackageDB]
readPackageDbList "clear" = [Nothing]
readPackageDbList "global" = [Just GlobalPackageDB]
Expand Down
49 changes: 49 additions & 0 deletions Cabal/Distribution/Types/Flag.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,11 +2,14 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Distribution.Types.Flag (
-- * Package flag
PackageFlag(..),
emptyFlag,
-- * Flag name
FlagName,
mkFlagName,
unFlagName,
-- * Flag assignment
FlagAssignment,
mkFlagAssignment,
unFlagAssignment,
Expand All @@ -17,8 +20,13 @@ module Distribution.Types.Flag (
nullFlagAssignment,
showFlagValue,
dispFlagAssignment,
showFlagAssignment,
parsecFlagAssignment,
parsecFlagAssignmentNonEmpty,
-- ** Legacy formats
legacyShowFlagAssignment,
legacyShowFlagAssignment',
legacyParsecFlagAssignment,
) where

import Prelude ()
Expand Down Expand Up @@ -294,4 +302,45 @@ parsecFlagAssignmentNonEmpty = mkFlagAssignment . toList <$>
f <- parsec
return (f, False)

-- | Show flag assignment.
--
-- @since 3.4.0.0
showFlagAssignment :: FlagAssignment -> String
showFlagAssignment = prettyShow . dispFlagAssignment

-------------------------------------------------------------------------------
-- Legacy: without requiring +
-------------------------------------------------------------------------------

-- | We need this as far as we support custom setups older than 2.2.0.0
--
-- @since 3.4.0.0
legacyShowFlagAssignment :: FlagAssignment -> String
legacyShowFlagAssignment =
prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment'

-- | @since 3.4.0.0
legacyShowFlagAssignment' :: FlagAssignment -> [String]
legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment

-- | @since 3.4.0.0
legacyShowFlagValue :: (FlagName, Bool) -> String
legacyShowFlagValue (f, True) = unFlagName f
legacyShowFlagValue (f, False) = '-' : unFlagName f

-- |
-- We need this as far as we support custom setups older than 2.2.0.0
--
-- @since 3.4.0.0
legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment
legacyParsecFlagAssignment = mkFlagAssignment <$>
P.sepBy (onFlag <|> offFlag) P.skipSpaces1
where
onFlag = do
_ <- P.optional (P.char '+')
f <- parsec
return (f, True)
offFlag = do
_ <- P.char '-'
f <- parsec
return (f, False)
36 changes: 18 additions & 18 deletions cabal-install/Distribution/Client/Install.hs
Original file line number Diff line number Diff line change
Expand Up @@ -138,9 +138,10 @@ import Distribution.Types.PackageVersionConstraint
import Distribution.Types.MungedPackageId
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
( PackageDescription, GenericPackageDescription(..), PackageFlag(..)
, FlagAssignment, mkFlagAssignment, unFlagAssignment
, showFlagValue, diffFlagAssignment, nullFlagAssignment )
( PackageDescription, GenericPackageDescription(..) )
import Distribution.Types.Flag
( PackageFlag(..), FlagAssignment, mkFlagAssignment
, showFlagAssignment, diffFlagAssignment, nullFlagAssignment )
import Distribution.PackageDescription.Configuration
( finalizePD )
import Distribution.Version
Expand Down Expand Up @@ -654,24 +655,26 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
showPkg (pkg, _) = prettyShow (packageId pkg) ++
showLatest (pkg)

showPkgAndReason (ReadyPackage pkg', pr) = prettyShow (packageId pkg') ++
showLatest pkg' ++
showFlagAssignment (nonDefaultFlags pkg') ++
showStanzas (confPkgStanzas pkg') ++
showDep pkg' ++
case pr of
NewPackage -> " (new package)"
NewVersion _ -> " (new version)"
Reinstall _ cs -> " (reinstall)" ++ case cs of
showPkgAndReason (ReadyPackage pkg', pr) = unwords
[ prettyShow (packageId pkg')
, showLatest pkg'
, showFlagAssignment (nonDefaultFlags pkg')
, showStanzas (confPkgStanzas pkg')
, showDep pkg'
, case pr of
NewPackage -> "(new package)"
NewVersion _ -> "(new version)"
Reinstall _ cs -> "(reinstall)" ++ case cs of
[] -> ""
diff -> " (changes: " ++ intercalate ", " (map change diff)
diff -> "(changes: " ++ intercalate ", " (map change diff)
++ ")"
]

showLatest :: Package srcpkg => srcpkg -> String
showLatest pkg = case mLatestVersion of
Just latestVersion ->
if packageVersion pkg < latestVersion
then (" (latest: " ++ prettyShow latestVersion ++ ")")
then ("(latest: " ++ prettyShow latestVersion ++ ")")
else ""
Nothing -> ""
where
Expand All @@ -694,10 +697,7 @@ printPlan dryRun verbosity plan sourcePkgDb = case plan of
in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment

showStanzas :: [OptionalStanza] -> String
showStanzas = concatMap ((" *" ++) . showStanza)

showFlagAssignment :: FlagAssignment -> String
showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment
showStanzas = unwords . map (("*" ++) . showStanza)

change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed"
change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> "
Expand Down
6 changes: 2 additions & 4 deletions cabal-install/Distribution/Client/PackageHash.hs
Original file line number Diff line number Diff line change
Expand Up @@ -30,8 +30,8 @@ import Distribution.Package
, PkgconfigName )
import Distribution.System
( Platform, OS(Windows, OSX), buildOS )
import Distribution.PackageDescription
( FlagAssignment, unFlagAssignment, showFlagValue )
import Distribution.Types.Flag
( FlagAssignment, showFlagAssignment )
import Distribution.Simple.Compiler
( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
, ProfDetailLevel(..), showProfDetailLevel )
Expand Down Expand Up @@ -315,5 +315,3 @@ renderPackageHashInputs PackageHashInputs{
opt key def format value
| value == def = Nothing
| otherwise = entry key format value

showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment
31 changes: 13 additions & 18 deletions cabal-install/Distribution/Client/ProjectOrchestration.hs
Original file line number Diff line number Diff line change
Expand Up @@ -143,9 +143,8 @@ import Distribution.Types.UnqualComponentName
import Distribution.Solver.Types.OptionalStanza

import Distribution.Package
import Distribution.PackageDescription
( FlagAssignment, unFlagAssignment, showFlagValue
, diffFlagAssignment )
import Distribution.Types.Flag
( FlagAssignment, showFlagAssignment, diffFlagAssignment )
import Distribution.Simple.LocalBuildInfo
( ComponentName(..), pkgComponents )
import Distribution.Simple.Flag
Expand Down Expand Up @@ -853,21 +852,20 @@ printPlan verbosity
| otherwise = "will"

showPkgAndReason :: ElaboratedReadyPackage -> String
showPkgAndReason (ReadyPackage elab) =
" - " ++
(if verbosity >= deafening
showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $
[ " -"
, if verbosity >= deafening
then prettyShow (installedUnitId elab)
else prettyShow (packageId elab)
) ++
(case elabPkgOrComp elab of
, case elabPkgOrComp elab of
ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg)
ElabComponent comp ->
" (" ++ showComp elab comp ++ ")"
) ++
showFlagAssignment (nonDefaultFlags elab) ++
showConfigureFlags elab ++
let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in
" (" ++ showBuildStatus buildStatus ++ ")"
"(" ++ showComp elab comp ++ ")"
, showFlagAssignment (nonDefaultFlags elab)
, showConfigureFlags elab
, let buildStatus = pkgsBuildStatus Map.! installedUnitId elab
in "(" ++ showBuildStatus buildStatus ++ ")"
]

showComp elab comp =
maybe "custom" prettyShow (compComponentName comp) ++
Expand All @@ -892,14 +890,11 @@ printPlan verbosity
showTargets elab
| null (elabBuildTargets elab) = ""
| otherwise
= " ("
= "("
++ intercalate ", " [ showComponentTarget (packageId elab) t
| t <- elabBuildTargets elab ]
++ ")"

showFlagAssignment :: FlagAssignment -> String
showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment

showConfigureFlags elab =
let fullConfigureFlags
= setupHsConfigureFlags
Expand Down