Commit d3a5d903 authored by Duncan Coutts's avatar Duncan Coutts Committed by Mikhail Glushenkov

Split FlagAssignment printer/parser out of UserConstraint ones

We want to reuse the FlagAssignment printer/parser for the config files.

(cherry picked from commit d0fb249e)
parent 5f6614a6
......@@ -44,7 +44,9 @@ module Distribution.Client.Targets (
UserConstraint(..),
userConstraintPackageName,
readUserConstraint,
userToPackageConstraint
userToPackageConstraint,
dispFlagAssignment,
parseFlagAssignment,
) where
......@@ -758,12 +760,6 @@ instance Text UserConstraint where
<+> Disp.text "source"
disp (UserConstraintFlags pkgname flags) = disp pkgname
<+> dispFlagAssignment flags
where
dispFlagAssignment = Disp.hsep . map dispFlagValue
dispFlagValue (f, True) = Disp.char '+' <> dispFlagName f
dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f
dispFlagName (FlagName f) = Disp.text f
disp (UserConstraintStanzas pkgname stanzas) = disp pkgname
<+> dispStanzas stanzas
where
......@@ -773,37 +769,51 @@ instance Text UserConstraint where
parse = parse >>= parseConstraint
where
spaces = Parse.satisfy isSpace >> Parse.skipSpaces
parseConstraint pkgname =
((parse >>= return . UserConstraintVersion pkgname)
+++ (do spaces
+++ (do skipSpaces1
_ <- Parse.string "installed"
return (UserConstraintInstalled pkgname))
+++ (do spaces
+++ (do skipSpaces1
_ <- Parse.string "source"
return (UserConstraintSource pkgname))
+++ (do spaces
+++ (do skipSpaces1
_ <- Parse.string "test"
return (UserConstraintStanzas pkgname [TestStanzas]))
+++ (do spaces
+++ (do skipSpaces1
_ <- Parse.string "bench"
return (UserConstraintStanzas pkgname [BenchStanzas])))
<++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))
parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue)
parseFlagValue =
(do Parse.optional (Parse.char '+')
f <- parseFlagName
return (f, True))
+++ (do _ <- Parse.char '-'
f <- parseFlagName
return (f, False))
parseFlagName = liftM FlagName ident
ident :: Parse.ReadP r String
ident = Parse.munch1 identChar >>= \s -> check s >> return s
where
identChar c = isAlphaNum c || c == '_' || c == '-'
check ('-':_) = Parse.pfail
check _ = return ()
<++ (do skipSpaces1
flags <- parseFlagAssignment
return (UserConstraintFlags pkgname flags))
--TODO: [code cleanup] move these somewhere else
dispFlagAssignment :: FlagAssignment -> Disp.Doc
dispFlagAssignment = Disp.hsep . map dispFlagValue
where
dispFlagValue (f, True) = Disp.char '+' <> dispFlagName f
dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f
dispFlagName (FlagName f) = Disp.text f
parseFlagAssignment :: Parse.ReadP r FlagAssignment
parseFlagAssignment = Parse.sepBy1 parseFlagValue skipSpaces1
where
parseFlagValue =
(do Parse.optional (Parse.char '+')
f <- parseFlagName
return (f, True))
+++ (do _ <- Parse.char '-'
f <- parseFlagName
return (f, False))
parseFlagName = liftM (FlagName . lowercase) ident
ident :: Parse.ReadP r String
ident = Parse.munch1 identChar >>= \s -> check s >> return s
where
identChar c = isAlphaNum c || c == '_' || c == '-'
check ('-':_) = Parse.pfail
check _ = return ()
skipSpaces1 :: Parse.ReadP r ()
skipSpaces1 = Parse.satisfy isSpace >> Parse.skipSpaces
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