Skip to content

GitLab

C
Cabal
Unverified Commit 4125d520 authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub
Browse files
Options

Merge pull request #6777 from phadej/monoid-field-parsec 

Remove Text RelaxDeps instances
parents 867e45e9 107c641e
Hide whitespace changes
Inline Side-by-side
Showing with 153 additions and 89 deletions
cabal-install/Distribution/Client/Config.hs
View file @ 4125d520
......@@ -129,7 +129,7 @@ import qualified Distribution.Deprecated.ReadP as Parse
import Distribution.Compat.Semigroup
import qualified Text.PrettyPrint as Disp
( render, text, empty )
import Distribution.Parsec (parsec, simpleParsec)
import Distribution.Parsec (parsec, simpleParsec, parsecOptCommaList)
import Distribution.Pretty (pretty)
import Text.PrettyPrint
( ($+$) )
......@@ -960,14 +960,14 @@ configFieldDescriptions src =
(configureExOptions ParseArgs src)
[]
[let pkgs = (Just . AllowOlder . RelaxDepsSome)
`fmap` parseOptCommaList Text.parse
`fmap` parsecOptCommaList parsec
parseAllowOlder = ((Just . AllowOlder . toRelaxDeps)
`fmap` Text.parse) Parse.<++ pkgs
in simpleField "allow-older"
(showRelaxDeps . fmap unAllowOlder) parseAllowOlder
configAllowOlder (\v flags -> flags { configAllowOlder = v })
,let pkgs = (Just . AllowNewer . RelaxDepsSome)
`fmap` parseOptCommaList Text.parse
`fmap` parsecOptCommaList parsec
parseAllowNewer = ((Just . AllowNewer . toRelaxDeps)
`fmap` Text.parse) Parse.<++ pkgs
in simpleField "allow-newer"
......
cabal-install/Distribution/Client/IndexUtils/ActiveRepos.hs
View file @ 4125d520
......@@ -14,7 +14,7 @@ import Distribution.Client.Types.RepoName (RepoName (..))
import Prelude ()
import Distribution.FieldGrammar.Described
import Distribution.Parsec (Parsec (..), parsecLeadingCommaList)
import Distribution.Parsec (Parsec (..), parsecLeadingCommaNonEmpty)
import Distribution.Pretty (Pretty (..), prettyShow)
import qualified Distribution.Compat.CharParsing as P
......@@ -63,7 +63,7 @@ instance Pretty ActiveRepos where
instance Parsec ActiveRepos where
parsec = ActiveRepos [] <$ P.try (P.string ":none")
<|> do
repos <- parsecLeadingCommaList parsec
repos <- parsecLeadingCommaNonEmpty parsec
return (ActiveRepos (toList repos))
instance Described ActiveRepos where
......
cabal-install/Distribution/Client/ProjectConfig/Legacy.hs
View file @ 4125d520
......@@ -76,7 +76,7 @@ import Distribution.Deprecated.ReadP
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint
( Doc, ($+$) )
import qualified Distribution.Deprecated.ParseUtils as ParseUtils (field)
import qualified Distribution.Deprecated.ParseUtils as ParseUtils
import Distribution.Deprecated.ParseUtils
( ParseResult(..), PError(..), syntaxError, PWarning(..)
, simpleField, commaNewLineListField, newLineListField, parseTokenQ
......@@ -87,6 +87,8 @@ import Distribution.Simple.Command
, OptionField, option, reqArg' )
import Distribution.Types.PackageVersionConstraint
( PackageVersionConstraint )
import Distribution.Parsec (Parsec (..), ParsecParser)
import Distribution.Pretty (Pretty (..))
import qualified Data.Map as Map
......@@ -965,13 +967,13 @@ legacySharedConfigFieldDescrs =
disp parse
configPreferences (\v conf -> conf { configPreferences = v })
, monoidField "allow-older"
(maybe mempty disp) (fmap Just parse)
, monoidFieldParsec "allow-older"
(maybe mempty pretty) (fmap Just parsec)
(fmap unAllowOlder . configAllowOlder)
(\v conf -> conf { configAllowOlder = fmap AllowOlder v })
, monoidField "allow-newer"
(maybe mempty disp) (fmap Just parse)
, monoidFieldParsec "allow-newer"
(maybe mempty pretty) (fmap Just parsec)
(fmap unAllowNewer . configAllowNewer)
(\v conf -> conf { configAllowNewer = fmap AllowNewer v })
]
......@@ -1425,10 +1427,11 @@ remoteRepoSectionDescr = SectionDescr
-- | Parser combinator for simple fields which uses the field type's
-- 'Monoid' instance for combining multiple occurrences of the field.
monoidField :: Monoid a => String -> (a -> Doc) -> ReadP a a
-> (b -> a) -> (a -> b -> b) -> FieldDescr b
monoidField name showF readF get' set =
liftField get' set' $ ParseUtils.field name showF readF
monoidFieldParsec
:: Monoid a => String -> (a -> Doc) -> ParsecParser a
-> (b -> a) -> (a -> b -> b) -> FieldDescr b
monoidFieldParsec name showF readF get' set =
liftField get' set' $ ParseUtils.fieldParsec name showF readF
where
set' xs b = set (get' b `mappend` xs) b
......
cabal-install/Distribution/Client/Setup.hs
View file @ 4125d520
......@@ -81,7 +81,7 @@ import Distribution.Client.Targets
( UserConstraint, readUserConstraint )
import Distribution.Utils.NubList
( NubList, toNubList, fromNubList)
import Distribution.Parsec (simpleParsec, parsec)
import Distribution.Parsec (CabalParsing, simpleParsec, parsec, eitherParsec )
import Distribution.Pretty (prettyShow)
import Distribution.Solver.Types.ConstraintSource
......@@ -123,10 +123,11 @@ import Distribution.PackageDescription
import Distribution.System ( Platform )
import Distribution.Deprecated.Text
( Text(..), display )
import qualified Distribution.Compat.CharParsing as P
import Distribution.ReadE
( ReadE(..), succeedReadE, parsecToReadE )
import qualified Distribution.Deprecated.ReadP as Parse
( ReadP, char, sepBy1 )
( char, sepBy1 )
import Distribution.Verbosity
( Verbosity, lessVerbose, normal, verboseNoFlags, verboseNoTimestamp )
import Distribution.Simple.Utils
......@@ -137,7 +138,6 @@ import Distribution.Client.GlobalFlags
)
import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)
import Distribution.Parsec.Newtypes (SpecVersion (..))
import Distribution.Parsec (eitherParsec)
import Data.List
( deleteFirstsBy )
......@@ -717,14 +717,14 @@ writeGhcEnvironmentFilesPolicyPrinter = \case
NoFlag -> []
relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps)
relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps)
relaxDepsParser =
(Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',')
(Just . RelaxDepsSome . toList) `fmap` P.sepByNonEmpty parsec (P.char ',')
relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]
relaxDepsPrinter Nothing = []
relaxDepsPrinter (Just RelaxDepsAll) = [Nothing]
relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs
relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs
instance Monoid ConfigExFlags where
......
cabal-install/Distribution/Client/Types/AllowNewer.hs
View file @ 4125d520
......@@ -3,6 +3,7 @@ module Distribution.Client.Types.AllowNewer (
AllowNewer (..),
AllowOlder (..),
RelaxDeps (..),
mkRelaxDepSome,
RelaxDepMod (..),
RelaxDepScope (..),
RelaxDepSubject (..),
......@@ -13,15 +14,18 @@ module Distribution.Client.Types.AllowNewer (
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Types.PackageId (PackageId, pkgVersion)
import Distribution.Types.PackageId (PackageId, PackageIdentifier (..))
import Distribution.Types.PackageName (PackageName, mkPackageName)
import Distribution.Types.Version (nullVersion)
import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
import Distribution.Deprecated.ParseUtils (parseOptCommaList)
import qualified Distribution.Deprecated.ReadP as Parse
import Distribution.Deprecated.Text (Text (..))
import Distribution.Parsec (CabalParsing, Parsec (..), parsecLeadingCommaList)
import Distribution.Pretty (Pretty (..))
-- $setup
-- >>> import Distribution.Parsec
-- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled,
-- it may make sense to move these definitions to the Solver.Types
......@@ -82,59 +86,95 @@ data RelaxDepSubject = RelaxDepSubjectAll
| RelaxDepSubjectPkg !PackageName
deriving (Eq, Ord, Read, Show, Generic)
instance Text RelaxedDep where
disp (RelaxedDep scope rdmod subj) = case scope of
RelaxDepScopeAll -> Disp.text "all:" Disp.<> modDep
RelaxDepScopePackage p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep
RelaxDepScopePackageId p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep
instance Pretty RelaxedDep where
pretty (RelaxedDep scope rdmod subj) = case scope of
RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep
RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
where
modDep = case rdmod of
RelaxDepModNone -> disp subj
RelaxDepModCaret -> Disp.char '^' Disp.<> disp subj
parse = RelaxedDep <$> scopeP <*> modP <*> parse
where
-- "greedy" choices
scopeP = (pure RelaxDepScopeAll <* Parse.char '*' <* Parse.char ':')
Parse.<++ (pure RelaxDepScopeAll <* Parse.string "all:")
Parse.<++ (RelaxDepScopePackageId <$> pidP <* Parse.char ':')
Parse.<++ (RelaxDepScopePackage <$> parse <* Parse.char ':')
Parse.<++ (pure RelaxDepScopeAll)
modP = (pure RelaxDepModCaret <* Parse.char '^')
Parse.<++ (pure RelaxDepModNone)
-- | Stricter 'PackageId' parser which doesn't overlap with 'PackageName' parser
pidP = do
p0 <- parse
when (pkgVersion p0 == nullVersion) Parse.pfail
pure p0
instance Text RelaxDepSubject where
disp RelaxDepSubjectAll = Disp.text "all"
disp (RelaxDepSubjectPkg pn) = disp pn
parse = (pure RelaxDepSubjectAll <* Parse.char '*') Parse.<++ pkgn
RelaxDepModNone -> pretty subj
RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj
instance Parsec RelaxedDep where
parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)
-- continuation after *
relaxedDepStarP :: CabalParsing m => m RelaxedDep
relaxedDepStarP =
RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
<|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)
-- continuation after package identifier
relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep
relaxedDepPkgidP pid@(PackageIdentifier pn v)
| pn == mkPackageName "all"
, v == nullVersion
= RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
<|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)
| v == nullVersion
= RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec
<|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn))
| otherwise
= RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec
modP :: P.CharParsing m => m RelaxDepMod
modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone
instance Pretty RelaxDepSubject where
pretty RelaxDepSubjectAll = Disp.text "*"
pretty (RelaxDepSubjectPkg pn) = pretty pn
instance Parsec RelaxDepSubject where
parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn
where
pkgn = do
pn <- parse
pure (if (pn == mkPackageName "all")
then RelaxDepSubjectAll
else RelaxDepSubjectPkg pn)
instance Text RelaxDeps where
disp rd | not (isRelaxDeps rd) = Disp.text "none"
disp (RelaxDepsSome pkgs) = Disp.fsep .
pn <- parsec
pure $ if pn == mkPackageName "all"
then RelaxDepSubjectAll
else RelaxDepSubjectPkg pn
instance Pretty RelaxDeps where
pretty rd | not (isRelaxDeps rd) = Disp.text "none"
pretty (RelaxDepsSome pkgs) = Disp.fsep .
Disp.punctuate Disp.comma .
map disp $ pkgs
disp RelaxDepsAll = Disp.text "all"
map pretty $ pkgs
pretty RelaxDepsAll = Disp.text "all"
parse = (const mempty <$> ((Parse.string "none" Parse.+++
Parse.string "None") <* Parse.eof))
Parse.<++ (const RelaxDepsAll <$> ((Parse.string "all" Parse.+++
Parse.string "All" Parse.+++
Parse.string "*") <* Parse.eof))
Parse.<++ ( RelaxDepsSome <$> parseOptCommaList parse)
-- |
--
-- >>> simpleParsec "all" :: Maybe RelaxDeps
-- Just RelaxDepsAll
--
-- >>> simpleParsec "none" :: Maybe RelaxDeps
-- Just (RelaxDepsSome [])
--
-- >>> simpleParsec "*, *" :: Maybe RelaxDeps
-- Just RelaxDepsAll
--
-- >>> simpleParsec "*:*" :: Maybe RelaxDeps
-- Just RelaxDepsAll
--
-- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps
-- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))])
--
-- This is not a glitch, even it looks like:
--
-- >>> simpleParsec ", all" :: Maybe RelaxDeps
-- Just RelaxDepsAll
--
instance Parsec RelaxDeps where
parsec = do
xs <- parsecLeadingCommaList parsec
pure $ case xs of
[RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
-> RelaxDepsAll
[RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]
| pn == mkPackageName "none"
-> mempty
_ -> mkRelaxDepSome xs
instance Binary RelaxDeps
instance Binary RelaxDepMod
......@@ -160,16 +200,25 @@ isRelaxDeps (RelaxDepsSome []) = False
isRelaxDeps (RelaxDepsSome (_:_)) = True
isRelaxDeps RelaxDepsAll = True
-- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@.
mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps
mkRelaxDepSome xs
| any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs
= RelaxDepsAll
| otherwise
= RelaxDepsSome xs
-- | 'RelaxDepsAll' is the /absorbing element/
instance Semigroup RelaxDeps where
-- identity element
RelaxDepsSome [] <> r = r
l@(RelaxDepsSome _) <> RelaxDepsSome [] = l
-- absorbing element
l@RelaxDepsAll <> _ = l
(RelaxDepsSome _) <> r@RelaxDepsAll = r
-- combining non-{identity,absorbing} elements
(RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b)
-- identity element
RelaxDepsSome [] <> r = r
l@(RelaxDepsSome _) <> RelaxDepsSome [] = l
-- absorbing element
l@RelaxDepsAll <> _ = l
(RelaxDepsSome _) <> r@RelaxDepsAll = r
-- combining non-{identity,absorbing} elements
(RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b)
-- | @'RelaxDepsSome' []@ is the /identity element/
instance Monoid RelaxDeps where
......
cabal-install/Distribution/Deprecated/ParseUtils.hs
View file @ 4125d520
......@@ -39,6 +39,8 @@ module Distribution.Deprecated.ParseUtils (
optsField, liftField, boolField, parseQuoted, parseMaybeQuoted,
readPToMaybe,
fieldParsec,
UnrecFieldParser, warnUnrec, ignoreUnrec,
) where
......@@ -67,6 +69,7 @@ import qualified Text.Read as Read
import qualified Data.Map as Map
import qualified Control.Monad.Fail as Fail
import Distribution.Parsec (ParsecParser, explicitEitherParsec)
-- -----------------------------------------------------------------------------
......@@ -188,6 +191,12 @@ field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field name showF readF =
FieldDescr name showF (\line val _st -> runP line name readF val)
fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec name showF readF =
FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of
Left err -> ParseFailed (FromString err (Just line))
Right x -> ParseOk [] x
-- Lift a field descriptor storing into an 'a' to a field descriptor storing
-- into a 'b'.
liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
......@@ -721,4 +730,4 @@ parseFlagAssignment = mkFlagAssignment <$>
-------------------------------------------------------------------------------
showTestedWith :: (CompilerFlavor, VersionRange) -> Doc
showTestedWith = pretty . pack' TestedWith
\ No newline at end of file
showTestedWith = pretty . pack' TestedWith
cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
View file @ 4125d520
......@@ -15,7 +15,6 @@ import Data.List
import Network.URI (URI)
import Distribution.Deprecated.ParseUtils
import Distribution.Deprecated.Text as Text
import qualified Distribution.Deprecated.ReadP as Parse
import Distribution.Package
......@@ -29,6 +28,9 @@ import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Db
import Distribution.Types.PackageVersionConstraint
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Client.Types
import Distribution.Client.CmdInstall.ClientInstallFlags
import Distribution.Client.Dependency.Types
......@@ -256,21 +258,22 @@ prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool
prop_parsePackageLocationTokenQ (PackageLocationString str) =
runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str
prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Bool
prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Property
prop_roundtrip_printparse_RelaxedDep rdep =
runReadP Text.parse (Text.display rdep) == Just rdep
counterexample (prettyShow rdep) $
eitherParsec (prettyShow rdep) == Right rdep
prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Property
prop_roundtrip_printparse_RelaxDeps rdep =
counterexample (Text.display rdep) $
runReadP Text.parse (Text.display rdep) `ediffEq` Just rdep
counterexample (prettyShow rdep) $
eitherParsec (prettyShow rdep) `ediffEq` Right rdep
prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Property
prop_roundtrip_printparse_RelaxDeps' rdep =
counterexample rdep' $
runReadP Text.parse rdep' `ediffEq` Just rdep
eitherParsec rdep' `ediffEq` Right rdep
where
rdep' = go (Text.display rdep)
rdep' = go (prettyShow rdep)
-- replace 'all' tokens by '*'
go :: String -> String
......@@ -848,7 +851,7 @@ instance Arbitrary AllowOlder where
instance Arbitrary RelaxDeps where
arbitrary = oneof [ pure mempty
, RelaxDepsSome <$> shortListOf1 3 arbitrary
, mkRelaxDepSome <$> shortListOf1 3 arbitrary
, pure RelaxDepsAll
]
......
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