Permalink
Browse files

Merge pull request #1163 from 23Skidoo/sandbox-constraints-error

Make the UserConstraint parser non-ambiguous.
  • Loading branch information...
2 parents 037fed7 + 060b05b commit cfb158712f5adc39af1a87347a5d43db6a925166 @23Skidoo 23Skidoo committed Jan 1, 2013
@@ -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
@@ -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)
@@ -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
@@ -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
@@ -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

0 comments on commit cfb1587

Please sign in to comment.