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

Make the UserConstraint parser non-ambiguous.

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

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)

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

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

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