[commit: Cabal] master: Simpler flat (no sections) parsing for installed package info files (906cd6c)

[Duncan Coutts]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/906cd6cd36506c651bec127924c4ee05a1a961ed

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

commit 906cd6cd36506c651bec127924c4ee05a1a961ed
Author: Duncan Coutts <duncan at community.haskell.org>
Date:   Tue May 24 13:20:59 2011 +0000

    Simpler flat (no sections) parsing for installed package info files
    Otherwise we cannot use '{' '}' chars in field contents, as they
    get interpreted as layout syntax. We want this for things like:
      library-dirs: ${pkgroot}/../libfoo/

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

 Distribution/InstalledPackageInfo.hs |    4 ++--
 Distribution/ParseUtils.hs           |   26 +++++++++++++++++++++++---
 2 files changed, 25 insertions(+), 5 deletions(-)

diff --git a/Distribution/InstalledPackageInfo.hs b/Distribution/InstalledPackageInfo.hs
index ec90a08..f878405 100644
--- a/Distribution/InstalledPackageInfo.hs
+++ b/Distribution/InstalledPackageInfo.hs
@@ -66,7 +66,7 @@ module Distribution.InstalledPackageInfo (
 import Distribution.ParseUtils
          ( FieldDescr(..), ParseResult(..), PError(..), PWarning
          , simpleField, listField, parseLicenseQ
-         , showFields, showSingleNamedField, parseFields
+         , showFields, showSingleNamedField, parseFieldsFlat
          , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ
          , showFilePath, showToken, boolField, parseOptVersion
          , parseFreeText, showFreeText )
@@ -170,7 +170,7 @@ noVersion = Version{ versionBranch=[], versionTags=[] }
 -- Parsing
 
 parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo
-parseInstalledPackageInfo = parseFields all_fields emptyInstalledPackageInfo
+parseInstalledPackageInfo = parseFieldsFlat all_fields emptyInstalledPackageInfo
 
 -- -----------------------------------------------------------------------------
 -- Pretty-printing
diff --git a/Distribution/ParseUtils.hs b/Distribution/ParseUtils.hs
index 37b574c..5145321 100644
--- a/Distribution/ParseUtils.hs
+++ b/Distribution/ParseUtils.hs
@@ -52,8 +52,8 @@ module Distribution.ParseUtils (
         LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,
         runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,
         Field(..), fName, lineNo,
-        FieldDescr(..), ppField, ppFields, readFields,
-        showFields, showSingleNamedField, parseFields,
+        FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,
+        showFields, showSingleNamedField, parseFields, parseFieldsFlat,
         parseFilePathQ, parseTokenQ, parseTokenQ',
         parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,
         parseOptVersion, parsePackageNameQ, parseVersionRangeQ,
@@ -278,7 +278,14 @@ showSingleNamedField fields f =
 
 parseFields :: [FieldDescr a] -> a -> String -> ParseResult a
 parseFields fields initial = \str ->
-  readFields str >>= foldM setField initial
+  readFields str >>= accumFields fields initial
+
+parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a
+parseFieldsFlat fields initial = \str ->
+  readFieldsFlat str >>= accumFields fields initial
+
+accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
+accumFields fields = foldM setField
   where
     fieldMap = Map.fromList
       [ (name, f) | f@(FieldDescr name _ _) <- fields ]
@@ -355,6 +362,12 @@ readFields input = ifelse
   where ls = (lines . normaliseLineEndings) input
         tokens = (concatMap tokeniseLine . trimLines) ls
 
+readFieldsFlat :: String -> ParseResult [Field]
+readFieldsFlat input = mapM (mkField 0)
+                   =<< mkTree tokens
+  where ls = (lines . normaliseLineEndings) input
+        tokens = (concatMap tokeniseLineFlat . trimLines) ls
+
 -- attach line number and determine indentation
 trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]
 trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l'))
@@ -428,6 +441,13 @@ tokeniseLine (n0, i, t, l) = case split n0 l of
                       | otherwise = Span n s' : ss
           where s' = trimTrailing (trimLeading s)
 
+tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token]
+tokeniseLineFlat (n0, i, t, l)
+  | null l'   = []
+  | otherwise = [Line n0 i t l']
+  where
+    l' = trimTrailing (trimLeading l)
+
 trimLeading, trimTrailing :: String -> String
 trimLeading  = dropWhile isSpace
 trimTrailing = reverse . dropWhile isSpace . reverse