Merge pull request #6781 from phadej/more-described

More described
haskell · May 12, 2020 · c753f62 · c753f62
2 parents e015931 + 2142a6a
commit c753f62
Show file tree

Hide file tree

Showing 4 changed files with 55 additions and 7 deletions.
diff --git a/Cabal/Distribution/System.hs b/Cabal/Distribution/System.hs
@@ -50,6 +50,7 @@ import Distribution.Utils.Generic (lowercase)
 
 import Distribution.Parsec
 import Distribution.Pretty
+import Distribution.FieldGrammar.Described
 
 import qualified Distribution.Compat.CharParsing as P
 import qualified Text.PrettyPrint as Disp
@@ -132,6 +133,13 @@ instance Pretty OS where
 instance Parsec OS where
   parsec = classifyOS Compat <$> parsecIdent
 
+instance Described OS where
+  describe _ = REUnion
+    [ fromString al
+    | os <- knownOSs
+    , al <- prettyShow os : osAliases Compat os
+    ]
+
 classifyOS :: ClassificationStrictness -> String -> OS
 classifyOS strictness s =
   fromMaybe (OtherOS s) $ lookup (lowercase s) osMap
@@ -198,6 +206,12 @@ instance Pretty Arch where
 instance Parsec Arch where
   parsec = classifyArch Strict <$> parsecIdent
 
+instance Described Arch where
+  describe _ = REUnion
+    [ fromString (prettyShow arch)
+    | arch <- knownArches
+    ]
+
 classifyArch :: ClassificationStrictness -> String -> Arch
 classifyArch strictness s =
   fromMaybe (OtherArch s) $ lookup (lowercase s) archMap

diff --git a/Cabal/Distribution/Types/Flag.hs b/Cabal/Distribution/Types/Flag.hs
@@ -19,7 +19,7 @@ module Distribution.Types.Flag (
     dispFlagAssignment,
     parsecFlagAssignment,
     parsecFlagAssignmentNonEmpty,
-    describeFlagAssignment,
+    describeFlagAssignmentNonEmpty,
     ) where
 
 import Prelude ()
@@ -240,6 +240,36 @@ showFlagValue :: (FlagName, Bool) -> String
 showFlagValue (f, True)   = '+' : unFlagName f
 showFlagValue (f, False)  = '-' : unFlagName f
 
+-- | @since 3.4.0.0
+instance Pretty FlagAssignment where
+    pretty = dispFlagAssignment
+
+-- |
+--
+-- >>> simpleParsec "" :: Maybe FlagAssignment
+-- Just (fromList [])
+--
+-- >>> simpleParsec "+foo -bar" :: Maybe FlagAssignment
+-- Just (fromList [(FlagName "bar",(1,False)),(FlagName "foo",(1,True))])
+--
+-- >>> simpleParsec "-none -any" :: Maybe FlagAssignment
+-- Just (fromList [(FlagName "any",(1,False)),(FlagName "none",(1,False))])
+--
+-- >>> simpleParsec "+foo -foo +foo +foo" :: Maybe FlagAssignment
+-- Just (fromList [(FlagName "foo",(4,True))])
+--
+-- >>> simpleParsec "+foo -bar baz" :: Maybe FlagAssignment
+-- Nothing
+--
+-- @since 3.4.0.0
+--
+instance Parsec FlagAssignment where
+    parsec = parsecFlagAssignment
+
+instance Described FlagAssignment where
+    describe _ = REMunch RESpaces1 $
+        REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName)
+
 -- | Pretty-prints a flag assignment.
 dispFlagAssignment :: FlagAssignment -> Disp.Doc
 dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment
@@ -250,7 +280,7 @@ parsecFlagAssignment = mkFlagAssignment <$>
                        P.sepBy (onFlag <|> offFlag) P.skipSpaces1
   where
     onFlag = do
-        _ <- P.optional (P.char '+')
+        _ <- P.char '+'
         f <- parsec
         return (f, True)
     offFlag = do
@@ -276,6 +306,6 @@ parsecFlagAssignmentNonEmpty = mkFlagAssignment . toList <$>
         f <- parsec
         return (f, False)
 
-describeFlagAssignment :: GrammarRegex void
-describeFlagAssignment = REMunch1 RESpaces1 $
+describeFlagAssignmentNonEmpty :: GrammarRegex void
+describeFlagAssignmentNonEmpty = REMunch1 RESpaces1 $
     REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName)
diff --git a/Cabal/tests/UnitTests/Distribution/Described.hs b/Cabal/tests/UnitTests/Distribution/Described.hs
@@ -20,11 +20,12 @@ import qualified Distribution.Utils.CharSet as CS
 
 import Distribution.ModuleName                     (ModuleName)
 import Distribution.Types.Dependency               (Dependency)
-import Distribution.Types.Flag                     (FlagName)
+import Distribution.Types.Flag                     (FlagName, FlagAssignment)
 import Distribution.Types.PackageId                (PackageIdentifier)
 import Distribution.Types.PackageName              (PackageName)
 import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint)
 import Distribution.Types.Version                  (Version)
+import Distribution.System (OS, Arch)
 import Distribution.Types.VersionRange             (VersionRange)
 
 import qualified RERE         as RE
@@ -42,7 +43,10 @@ tests = testGroup "Described"
     , testDescribed (Proxy :: Proxy Version)
     , testDescribed (Proxy :: Proxy VersionRange)
     , testDescribed (Proxy :: Proxy FlagName)
+    , testDescribed (Proxy :: Proxy FlagAssignment)
     , testDescribed (Proxy :: Proxy ModuleName)
+    , testDescribed (Proxy :: Proxy OS)
+    , testDescribed (Proxy :: Proxy Arch)
     ]
 
 -------------------------------------------------------------------------------

diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs
@@ -79,7 +79,7 @@ import Distribution.Types.PackageVersionConstraint
 import Distribution.PackageDescription
          ( GenericPackageDescription )
 import Distribution.Types.Flag
-         ( nullFlagAssignment, parsecFlagAssignmentNonEmpty, describeFlagAssignment )
+         ( nullFlagAssignment, parsecFlagAssignmentNonEmpty, describeFlagAssignmentNonEmpty )
 import Distribution.Version
          ( VersionRange, anyVersion, isAnyVersion )
 import Distribution.Pretty (Pretty (..), prettyShow)
@@ -745,7 +745,7 @@ instance Described UserConstraint where
             , fromString "source"
             , fromString "test"
             , fromString "bench"
-            , describeFlagAssignment
+            , describeFlagAssignmentNonEmpty
             ]
 
         describePN :: GrammarRegex void