Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

Make the UserConstraint parser non-ambiguous. #1163

Merged
merged 4 commits into from

1 participant

@23Skidoo
Collaborator

Fixes #1159. Depends on #1162 (for unit tests).

23Skidoo added some commits
@23Skidoo 23Skidoo Spelling.
s/AmbigousParse/AmbiguousParse/
b9ee7a2
@23Skidoo 23Skidoo Spelling, 80-col violations. ee80bff
@23Skidoo 23Skidoo Add unit tests for the UserConstraint parser. 060b05b
@23Skidoo 23Skidoo Make the UserConstraint parser non-ambiguous.
`+++` and `<++` are right-associative, so `a +++ b +++ c <++ d` is parsed as
`(a +++ (b +++ (c <++ d)))`.

Fixes #1159.
03af50b
@23Skidoo 23Skidoo merged commit cfb1587 into from
@23Skidoo
Collaborator

Since #1162 has been already merged, I'm also merging this.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Jan 1, 2013
  1. @23Skidoo

    Spelling.

    23Skidoo authored
    s/AmbigousParse/AmbiguousParse/
  2. @23Skidoo

    Spelling, 80-col violations.

    23Skidoo authored
  3. @23Skidoo
  4. @23Skidoo

    Make the UserConstraint parser non-ambiguous.

    23Skidoo authored
    `+++` and `<++` are right-associative, so `a +++ b +++ c <++ d` is parsed as
    `(a +++ (b +++ (c <++ d)))`.
    
    Fixes #1159.
This page is out of date. Refresh to see the latest.
View
30 Cabal/Distribution/ParseUtils.hs
@@ -94,7 +94,7 @@ import Data.List (sortBy)
type LineNo = Int
-data PError = AmbigousParse String LineNo
+data PError = AmbiguousParse String LineNo
| NoParse String LineNo
| TabsError LineNo
| FromString String (Maybe LineNo)
@@ -139,8 +139,8 @@ runP line fieldname p s =
[] -> case [ x | (x,ys) <- results, all isSpace ys ] of
[a] -> ParseOk (utf8Warnings line fieldname s) a
[] -> ParseFailed (NoParse fieldname line)
- _ -> ParseFailed (AmbigousParse fieldname line)
- _ -> ParseFailed (AmbigousParse fieldname line)
+ _ -> ParseFailed (AmbiguousParse fieldname line)
+ _ -> ParseFailed (AmbiguousParse fieldname line)
where results = readP_to_S p s
runE :: LineNo -> String -> ReadE a -> String -> ParseResult a
@@ -157,10 +157,12 @@ utf8Warnings line fieldname s =
, '\xfffd' `elem` l ]
locatedErrorMsg :: PError -> (Maybe LineNo, String)
-locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.")
-locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.")
-locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.")
-locatedErrorMsg (FromString s n) = (n, s)
+locatedErrorMsg (AmbiguousParse f n) = (Just n,
+ "Ambiguous parse in field '"++f++"'.")
+locatedErrorMsg (NoParse f n) = (Just n,
+ "Parse of field '"++f++"' failed.")
+locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.")
+locatedErrorMsg (FromString s n) = (n, s)
syntaxError :: LineNo -> String -> ParseResult a
syntaxError n s = ParseFailed $ FromString s (Just n)
@@ -228,7 +230,8 @@ listField name showF readF get set =
where
set' xs b = set (get b ++ xs) b
-optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b
+optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])])
+ -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b
optsField name flavor get set =
liftField (fromMaybe [] . lookup flavor . get)
(\opts b -> set (reorder (update flavor opts (get b))) b) $
@@ -244,7 +247,7 @@ optsField name flavor get set =
-- TODO: this is a bit smelly hack. It's because we want to parse bool fields
-- liberally but not accept new parses. We cannot do that with ReadP
--- because it does not support warnings. We need a new parser framwork!
+-- because it does not support warnings. We need a new parser framework!
boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b
boolField name get set = liftField get set (FieldDescr name showF readF)
where
@@ -567,7 +570,8 @@ ifelse (Section n "if" cond thenpart:fs)
| otherwise = do tp <- ifelse thenpart
fs' <- ifelse fs
return (IfBlock n cond tp []:fs')
-ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'"
+ifelse (Section n "else" _ _:_) = syntaxError n
+ "stray 'else' with no preceding 'if'"
ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs'
fs''' <- ifelse fs
return (Section n s a fs'' : fs''')
@@ -593,7 +597,8 @@ betweenSpaces act = do skipSpaces
parseBuildTool :: ReadP r Dependency
parseBuildTool = do name <- parseBuildToolNameQ
- ver <- betweenSpaces $ parseVersionRangeQ <++ return anyVersion
+ ver <- betweenSpaces $
+ parseVersionRangeQ <++ return anyVersion
return $ Dependency name ver
parseBuildToolNameQ :: ReadP r PackageName
@@ -611,7 +616,8 @@ parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-')
-- eg "gtk+-2.0" is a valid pkg-config package _name_.
-- It then has a package version number like 2.10.13
parsePkgconfigDependency :: ReadP r Dependency
-parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._")
+parsePkgconfigDependency = do name <- munch1
+ (\c -> isAlphaNum c || c `elem` "+-._")
ver <- betweenSpaces $
parseVersionRangeQ <++ return anyVersion
return $ Dependency (PackageName name) ver
View
19 cabal-install/Distribution/Client/Targets.hs
@@ -708,17 +708,22 @@ readUserConstraint str =
--FIXME: use Text instance for FlagName and FlagAssignment
instance Text UserConstraint where
- disp (UserConstraintVersion pkgname verrange) = disp pkgname <+> disp verrange
- disp (UserConstraintInstalled pkgname) = disp pkgname <+> Disp.text "installed"
- disp (UserConstraintSource pkgname) = disp pkgname <+> Disp.text "source"
- disp (UserConstraintFlags pkgname flags) = disp pkgname <+> dispFlagAssignment flags
+ disp (UserConstraintVersion pkgname verrange) = disp pkgname
+ <+> disp verrange
+ disp (UserConstraintInstalled pkgname) = disp pkgname
+ <+> Disp.text "installed"
+ disp (UserConstraintSource pkgname) = disp pkgname
+ <+> 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
+ disp (UserConstraintStanzas pkgname stanzas) = disp pkgname
+ <+> dispStanzas stanzas
where
dispStanzas = Disp.hsep . map dispStanza
dispStanza TestStanzas = Disp.text "test"
@@ -729,7 +734,7 @@ instance Text UserConstraint where
spaces = Parse.satisfy isSpace >> Parse.skipSpaces
parseConstraint pkgname =
- (parse >>= return . UserConstraintVersion pkgname)
+ ((parse >>= return . UserConstraintVersion pkgname)
+++ (do spaces
_ <- Parse.string "installed"
return (UserConstraintInstalled pkgname))
@@ -741,7 +746,7 @@ instance Text UserConstraint where
return (UserConstraintStanzas pkgname [TestStanzas]))
+++ (do spaces
_ <- Parse.string "bench"
- return (UserConstraintStanzas pkgname [BenchStanzas]))
+ return (UserConstraintStanzas pkgname [BenchStanzas])))
<++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))
parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue)
View
13 cabal-install/cabal-install.cabal
@@ -165,3 +165,16 @@ Executable cabal
else
build-depends: base >= 3,
directory >= 1 && < 1.3
+
+Test-Suite unit-tests
+ type: exitcode-stdio-1.0
+ main-is: UnitTests.hs
+ hs-source-dirs: tests
+ build-depends:
+ base,
+ test-framework,
+ test-framework-hunit,
+ HUnit,
+ cabal-install,
+ Cabal
+ ghc-options: -Wall
View
15 cabal-install/tests/UnitTests.hs
@@ -0,0 +1,15 @@
+module Main
+ where
+
+import Test.Framework
+
+import qualified UnitTests.Distribution.Client.Targets
+
+tests :: [Test]
+tests = [
+ testGroup "Distribution.Client.Targets"
+ UnitTests.Distribution.Client.Targets.tests
+ ]
+
+main :: IO ()
+main = defaultMain tests
View
59 cabal-install/tests/UnitTests/Distribution/Client/Targets.hs
@@ -0,0 +1,59 @@
+module UnitTests.Distribution.Client.Targets (
+ tests
+ ) where
+
+import Distribution.Client.Targets (UserConstraint (..), readUserConstraint)
+import Distribution.Compat.ReadP (ReadP, readP_to_S)
+import Distribution.Package (PackageName (..))
+import Distribution.ParseUtils (parseCommaList)
+import Distribution.Text (parse)
+
+import Test.Framework as TF (Test)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit (Assertion, assertEqual)
+
+import Data.Char (isSpace)
+
+tests :: [TF.Test]
+tests = [ testCase "readUserConstraint" readUserConstraintTest
+ , testCase "parseUserConstraint" parseUserConstraintTest
+ , testCase "readUserConstraints" readUserConstraintsTest
+ ]
+
+readUserConstraintTest :: Assertion
+readUserConstraintTest =
+ assertEqual ("Couldn't read constraint: '" ++ constr ++ "'") expected actual
+ where
+ pkgName = "template-haskell"
+ constr = pkgName ++ " installed"
+
+ expected = UserConstraintInstalled (PackageName pkgName)
+ actual = let (Right r) = readUserConstraint constr in r
+
+parseUserConstraintTest :: Assertion
+parseUserConstraintTest =
+ assertEqual ("Couldn't parse constraint: '" ++ constr ++ "'") expected actual
+ where
+ pkgName = "template-haskell"
+ constr = pkgName ++ " installed"
+
+ expected = [UserConstraintInstalled (PackageName pkgName)]
+ actual = [ x | (x, ys) <- readP_to_S parseUserConstraint constr
+ , all isSpace ys]
+
+ parseUserConstraint :: ReadP r UserConstraint
+ parseUserConstraint = parse
+
+readUserConstraintsTest :: Assertion
+readUserConstraintsTest =
+ assertEqual ("Couldn't read constraints: '" ++ constr ++ "'") expected actual
+ where
+ pkgName = "template-haskell"
+ constr = pkgName ++ " installed"
+
+ expected = [[UserConstraintInstalled (PackageName pkgName)]]
+ actual = [ x | (x, ys) <- readP_to_S parseUserConstraints constr
+ , all isSpace ys]
+
+ parseUserConstraints :: ReadP r [UserConstraint]
+ parseUserConstraints = parseCommaList parse
Something went wrong with that request. Please try again.