[commit: Cabal] master: Fix BuildReport parser (27703e1)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/27703e1a060db0f0dff6d64dc0e2697047ce0d56

>---------------------------------------------------------------

commit 27703e1a060db0f0dff6d64dc0e2697047ce0d56
Author: Duncan Coutts <duncan at haskell.org>
Date:   Thu Aug 7 22:14:35 2008 +0000

    Fix BuildReport parser

>---------------------------------------------------------------

 .../Distribution/Client/BuildReports/Anonymous.hs  |   53 ++++++++++++++++----
 1 files changed, 43 insertions(+), 10 deletions(-)

diff --git a/cabal-install/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
index 7b27a0a..af831fd 100644
--- a/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
+++ b/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
@@ -31,8 +31,8 @@ import Distribution.Client.Types
 import qualified Distribution.Client.Types as BR
          ( BuildResult, BuildFailure(..), BuildSuccess(..)
          , DocsResult(..), TestsResult(..) )
-import Distribution.Client.ParseUtils
-         ( parseFields )
+import Distribution.Client.Utils
+         ( mergeBy, MergeResult(..) )
 import qualified Paths_cabal_install (version)
 
 import Distribution.Package
@@ -48,17 +48,21 @@ import Distribution.Compiler
 import qualified Distribution.Text as Text
          ( Text(disp, parse) )
 import Distribution.ParseUtils
-         ( FieldDescr(..), ParseResult(..)
-         , simpleField, listField, ppFields, locatedErrorMsg )
+         ( FieldDescr(..), ParseResult(..), Field(..)
+         , simpleField, listField, ppFields, readFields
+         , syntaxError, locatedErrorMsg )
+import Distribution.Simple.Utils
+         ( comparing )
+
 import qualified Distribution.Compat.ReadP as Parse
-         ( ReadP, pfail, munch1, char, option, skipSpaces )
+         ( ReadP, pfail, munch1, skipSpaces )
 import qualified Text.PrettyPrint.HughesPJ as Disp
          ( Doc, render, char, text )
 import Text.PrettyPrint.HughesPJ
          ( (<+>), (<>) )
 
 import Data.List
-         ( unfoldr )
+         ( unfoldr, sortBy )
 import Data.Char as Char
          ( isAlpha, isAlphaNum )
 
@@ -178,10 +182,35 @@ initialBuildReport = BuildReport {
 -- Parsing
 
 parse :: String -> Either String BuildReport
-parse s = case parseFields fieldDescrs initialBuildReport s of
+parse s = case parseFields s of
   ParseFailed perror -> Left  msg where (_, msg) = locatedErrorMsg perror
   ParseOk   _ report -> Right report
 
+--FIXME: this does not allow for optional or repeated fields
+parseFields :: String -> ParseResult BuildReport
+parseFields input = do
+  fields <- mapM extractField =<< readFields input
+  let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)
+                       sortedFieldDescrs
+                       (sortBy (comparing (\(_,name,_) -> name)) fields)
+  checkMerged initialBuildReport merged
+
+  where
+    extractField :: Field -> ParseResult (Int, String, String)
+    extractField (F line name value)  = return (line, name, value)
+    extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"
+    extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"
+
+    checkMerged report [] = return report
+    checkMerged report (merged:remaining) = case merged of
+      InBoth fieldDescr (line, _name, value) -> do
+        report' <- fieldSet fieldDescr line value report
+        checkMerged report' remaining
+      OnlyInRight (line, name, _) ->
+        syntaxError line ("Unrecognized field " ++ name)
+      OnlyInLeft  fieldDescr ->
+        fail ("Missing field " ++ fieldName fieldDescr)
+
 parseList :: String -> [BuildReport]
 parseList str =
   [ report | Right report <- map parse (split str) ]
@@ -226,15 +255,19 @@ fieldDescrs =
                                  testsOutcome   (\v r -> r { testsOutcome = v })
  ]
 
+sortedFieldDescrs :: [FieldDescr BuildReport]
+sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs
+
 dispFlag :: (FlagName, Bool) -> Disp.Doc
 dispFlag (FlagName name, True)  =                  Disp.text name
 dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name
 
 parseFlag :: Parse.ReadP r (FlagName, Bool)
 parseFlag = do
-  value <- Parse.option True (Parse.char '-' >> return False)
-  name  <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
-  return (FlagName name, value)
+  name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
+  case name of
+    ('-':flag) -> return (FlagName flag, False)
+    flag       -> return (FlagName flag, True)
 
 instance Text.Text InstallOutcome where
   disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid