Merge pull request #6854 from phadej/issue-6853

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

Author: phadej

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
 

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]

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)

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 ++ " -> "

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

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