From d2b58caf3824476eb26380679190e3871eb0518c Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 28 May 2020 11:28:37 +0300 Subject: [PATCH] Fix #6583: Use more lenient flag assignment parser in D.S.Setup --- Cabal/Distribution/Pretty.hs | 4 ++ Cabal/Distribution/Simple/Setup.hs | 15 ++---- Cabal/Distribution/Types/Flag.hs | 49 +++++++++++++++++++ cabal-install/Distribution/Client/Install.hs | 36 +++++++------- .../Distribution/Client/PackageHash.hs | 6 +-- .../Client/ProjectOrchestration.hs | 31 +++++------- 6 files changed, 89 insertions(+), 52 deletions(-) diff --git a/Cabal/Distribution/Pretty.hs b/Cabal/Distribution/Pretty.hs index ddf51c13652..f7e7893f9e6 100644 --- a/Cabal/Distribution/Pretty.hs +++ b/Cabal/Distribution/Pretty.hs @@ -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 diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs index f7b2a9b8c2e..502aca43fa0 100644 --- a/Cabal/Distribution/Simple/Setup.hs +++ b/Cabal/Distribution/Simple/Setup.hs @@ -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 @@ -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" @@ -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] diff --git a/Cabal/Distribution/Types/Flag.hs b/Cabal/Distribution/Types/Flag.hs index 9d60eadb5a9..9c1ea1f4a3f 100644 --- a/Cabal/Distribution/Types/Flag.hs +++ b/Cabal/Distribution/Types/Flag.hs @@ -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, @@ -17,8 +20,13 @@ module Distribution.Types.Flag ( nullFlagAssignment, showFlagValue, dispFlagAssignment, + showFlagAssignment, parsecFlagAssignment, parsecFlagAssignmentNonEmpty, + -- ** Legacy formats + legacyShowFlagAssignment, + legacyShowFlagAssignment', + legacyParsecFlagAssignment, ) where import Prelude () @@ -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) diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 49bd61d7893..8ad54146f71 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -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 @@ -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 @@ -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 ++ " -> " diff --git a/cabal-install/Distribution/Client/PackageHash.hs b/cabal-install/Distribution/Client/PackageHash.hs index cb6f492eee4..b3c0adc0be0 100644 --- a/cabal-install/Distribution/Client/PackageHash.hs +++ b/cabal-install/Distribution/Client/PackageHash.hs @@ -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 ) @@ -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 diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 52ba9e9486a..da15a4beccc 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -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 @@ -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) ++ @@ -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