Unverified Commit c753f62a authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub

Merge pull request #6781 from phadej/more-described

More described
parents e015931f 2142a6a0
......@@ -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
......
......@@ -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)
......@@ -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)
]
-------------------------------------------------------------------------------
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment