new cabal pretty printer.

Cabal.cabal

@@ -68,6 +68,7 @@ Library
         Distribution.PackageDescription.Configuration,
         Distribution.PackageDescription.Parse,
         Distribution.PackageDescription.Check,
+        Distribution.PackageDescription.PrettyPrint,
         Distribution.ParseUtils,
         Distribution.ReadE,
         Distribution.Simple,

Distribution/PackageDescription/Parse.hs

@@ -56,8 +56,14 @@ module Distribution.PackageDescription.Parse (
         -- ** Supplementary build information
         readHookedBuildInfo,
         parseHookedBuildInfo,
-        writeHookedBuildInfo,
-        showHookedBuildInfo,
+
+        pkgDescrFieldDescrs,
+        libFieldDescrs,
+        executableFieldDescrs,
+        binfoFieldDescrs,
+        sourceRepoFieldDescrs,
+        testSuiteFieldDescrs,
+        flagFieldDescrs
   ) where
 
 import Data.Char  (isSpace)
@@ -166,7 +172,8 @@ pkgDescrFieldDescrs =
 -- | Store any fields beginning with "x-" in the customFields field of
 --   a PackageDescription.  All other fields will generate a warning.
 storeXFieldsPD :: UnrecFieldParser PackageDescription
-storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = (f,val):(customFieldsPD pkg) }
+storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =
+                                                        (customFieldsPD pkg) ++ [(f,val)]}
 storeXFieldsPD _ _ = Nothing
 
 -- ---------------------------------------------------------------------------
@@ -184,7 +191,7 @@ libFieldDescrs =
 
 storeXFieldsLib :: UnrecFieldParser Library
 storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =
-    Just $ l {libBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi) }}
+    Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}}
 storeXFieldsLib _ _ = Nothing
 
 -- ---------------------------------------------------------------------------
@@ -356,7 +363,7 @@ binfoFieldDescrs =
            ghcProfOptions        (\val binfo -> binfo{ghcProfOptions=val})
  , listField   "ghc-shared-options"
            text               parseTokenQ
-           ghcSharedOptions      (\val binfo -> binfo{ghcSharedOptions=val})
+           ghcProfOptions        (\val binfo -> binfo{ghcSharedOptions=val})
  , optsField   "ghc-options"  GHC
            options            (\path  binfo -> binfo{options=path})
  , optsField   "hugs-options" Hugs
@@ -730,7 +737,7 @@ parsePackageDescription file = do
             flds <- collectFields parseExeFields sec_fields
             skipField
             (repos, flags, lib, exes, tests) <- getBody
-            return (repos, flags, lib, exes ++ [(exename, flds)], tests)
+            return (repos, flags, lib, (exename, flds): exes, tests)
 
         | sec_type == "test-suite" -> do
             when (null sec_label) $ lift $ syntaxError line_no
@@ -739,7 +746,7 @@ parsePackageDescription file = do
             flds <- collectFields (parseTestFields line_no) sec_fields
             skipField
             (repos, flags, lib, exes, tests) <- getBody
-            return (repos, flags, lib, exes, tests ++ [(testname, flds)])
+            return (repos, flags, lib, exes, (testname, flds): tests)
 
         | sec_type == "library" -> do
             when (not (null sec_label)) $ lift $

Distribution/PackageDescription/PrettyPrint.hs

+-----------------------------------------------------------------------------
+--
+-- Module      :  Distribution.PackageDescription.PrettyPrint
+-- Copyright   :  Jürgen Nicklisch-Franken 2010
+-- License     :  AllRightsReserved
+--
+-- Maintainer  : cabal-devel@haskell.org
+-- Stability   : provisional
+-- Portability : portable
+--
+-- | Pretty printing for cabal files
+--
+-----------------------------------------------------------------------------
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Isaac Jones nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.PackageDescription.PrettyPrint (
+    writeGenericPackageDescription,
+    showGenericPackageDescription,
+) where
+
+import Distribution.PackageDescription
+       (TestType(..), TestSuite(..), repoKind, SourceRepo(..),
+        customFieldsBI, CondTree(..), Condition(..), Condition,
+        FlagName(..), ConfVar(..), Flag, Executable(..), Library(..),
+        ConfVar, CondTree, Flag(..), PackageDescription(..),
+        condExecutables, condLibrary, genPackageFlags, packageDescription,
+        GenericPackageDescription(..))
+import Text.PrettyPrint
+       (comma, punctuate, fsep, sep, parens, char, nest,
+        empty, isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc,
+        render)
+import Distribution.Simple.Utils (writeUTF8File)
+import Distribution.ParseUtils (showFreeText, FieldDescr(..))
+import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,
+       sourceRepoFieldDescrs)
+import Distribution.Package (Dependency(..))
+import Distribution.Text (Text(..))
+import Data.Maybe (isJust, fromJust, isNothing)
+import Data.Version (showVersion)
+
+indentWith :: Int
+indentWith = 4
+
+-- | Recompile with false for regression testing
+simplifiedPrinting :: Bool
+simplifiedPrinting = False
+
+-- | Writes a .cabal file from a generic package description
+writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()
+writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)
+
+-- | Writes a generic package description to a string
+showGenericPackageDescription :: GenericPackageDescription -> String
+showGenericPackageDescription            = render . ppGenericPackageDescription
+
+ppGenericPackageDescription :: GenericPackageDescription -> Doc
+ppGenericPackageDescription gpd          =
+        ppPackageDescription (packageDescription gpd)
+        $+$ ppGenPackageFlags (genPackageFlags gpd)
+        $+$ ppLibrary (condLibrary gpd)
+        $+$ ppExecutables (condExecutables gpd)
+        $+$ ppTestSuites (condTestSuites gpd)
+
+ppPackageDescription :: PackageDescription -> Doc
+ppPackageDescription pd                  =      ppFields pkgDescrFieldDescrs pd
+                                                $+$ ppCustomFields (customFieldsPD pd)
+                                                $+$ ppSourceRepos (sourceRepos pd)
+
+ppSourceRepos :: [SourceRepo] -> Doc
+ppSourceRepos []                         = empty
+ppSourceRepos (hd:tl)                    = ppSourceRepo hd $+$ ppSourceRepos tl
+
+ppSourceRepo :: SourceRepo -> Doc
+ppSourceRepo repo                        =
+    emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$
+        (nest indentWith (ppFields sourceRepoFieldDescrs' repo))
+  where
+    sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]
+
+ppFields :: [FieldDescr a] -> a -> Doc
+ppFields fields x                        =
+    vcat [ ppField name (getter x)
+                         | FieldDescr name getter _ <- fields]
+
+ppField :: String -> Doc -> Doc
+ppField name fielddoc | isEmpty fielddoc = empty
+                      | otherwise        = text name <> colon <+> fielddoc
+
+ppDiffFields :: [FieldDescr a] -> a -> a -> Doc
+ppDiffFields fields x y                  =
+    vcat [ ppField name (getter x)
+                         | FieldDescr name getter _ <- fields,
+                            render (getter x) /= render (getter y)]
+
+ppCustomFields :: [(String,String)] -> Doc
+ppCustomFields flds                      = vcat [ppCustomField f | f <- flds]
+
+ppCustomField :: (String,String) -> Doc
+ppCustomField (name,val)                 = text name <> colon <+> showFreeText val
+
+ppGenPackageFlags :: [Flag] -> Doc
+ppGenPackageFlags flds                   = vcat [ppFlag f | f <- flds]
+
+ppFlag :: Flag -> Doc
+ppFlag (MkFlag name desc dflt manual)    =
+    emptyLine $ text "flag" <+> ppFlagName name $+$
+            (nest indentWith ((if null desc
+                                then empty
+                                else  text "Description: " <+> showFreeText desc) $+$
+                     (if dflt then empty else text "Default: False") $+$
+                     (if manual then text "Manual: True" else empty)))
+
+ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc
+ppLibrary Nothing                        = empty
+ppLibrary (Just condTree)                =
+    emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)
+  where
+    ppLib lib Nothing     = ppFields libFieldDescrs lib
+                            $$  ppCustomFields (customFieldsBI (libBuildInfo lib))
+    ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib
+                            $$  ppCustomFields (customFieldsBI (libBuildInfo lib))
+
+ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc
+ppExecutables exes                       =
+    vcat [emptyLine $ text ("executable " ++ n)
+              $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]
+  where
+    ppExe (Executable _ modulePath' buildInfo') Nothing =
+        (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')
+            $+$ ppFields binfoFieldDescrs buildInfo'
+            $+$  ppCustomFields (customFieldsBI buildInfo')
+    ppExe (Executable _ modulePath' buildInfo')
+            (Just (Executable _ modulePath2 buildInfo2)) =
+            (if modulePath' == "" || modulePath' == modulePath2
+                then empty else text "main-is:" <+> text modulePath')
+            $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
+            $+$ ppCustomFields (customFieldsBI buildInfo')
+
+ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc
+ppTestSuites suites =
+    emptyLine $ vcat [text ("test-suite " ++ n)
+              $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)| (n,condTree) <- suites]
+  where
+    ppTestSuite (TestSuite _ (ExeTest version filePath) buildInfo') Nothing =
+        (text "type:" <+> text ("exitcode-stdio-" ++ showVersion version))
+            $+$ (text "main-is:" <+> text filePath)
+            $+$ ppFields binfoFieldDescrs buildInfo'
+            $+$ ppCustomFields (customFieldsBI buildInfo')
+    ppTestSuite (TestSuite _ (LibTest version moduleName) buildInfo') Nothing =
+        (text "type:" <+> text ("library-" ++ showVersion version))
+            $+$ (text "test-module:" <+> disp moduleName)
+            $+$ ppFields binfoFieldDescrs buildInfo'
+            $+$ ppCustomFields (customFieldsBI buildInfo')
+    ppTestSuite (TestSuite _ _ buildInfo')
+                    (Just (TestSuite _ _ buildInfo2)) =
+            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
+            $+$ ppCustomFields (customFieldsBI buildInfo')
+
+ppCondition :: Condition ConfVar -> Doc
+ppCondition (Var x)                      = ppConfVar x
+ppCondition (Lit b)                      = text (show b)
+ppCondition (CNot c)                     = char '!' <> parens (ppCondition c)
+ppCondition (COr c1 c2)                  = parens $ sep [ppCondition c1, text "||"
+                                                         <+> ppCondition c2]
+ppCondition (CAnd c1 c2)                 = parens $ sep [ppCondition c1, text "&&"
+                                                         <+> ppCondition c2]
+ppConfVar :: ConfVar -> Doc
+ppConfVar (OS os)                        = text "os"   <> parens (disp os)
+ppConfVar (Arch arch)                    = text "arch" <> parens (disp arch)
+ppConfVar (Flag name)                    = text "flag" <> parens (ppFlagName name)
+ppConfVar (Impl c v)                     = text "impl" <> parens (disp c <+> disp v)
+
+ppFlagName :: FlagName -> Doc
+ppFlagName (FlagName name)               = text name
+
+ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) ->  Doc
+ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =
+    let res = ppDeps deps
+                $+$ (vcat $ map ppIf ifs)
+                $+$ ppIt it mbIt
+    in if isJust mbIt && isEmpty res
+        then ppCondTree ct Nothing ppIt
+        else res
+  where
+    ppIf (c,thenTree,mElseTree)          =
+        ((emptyLine $ text "if" <+> ppCondition c) $$
+          nest indentWith (ppCondTree thenTree
+                    (if simplifiedPrinting then (Just it) else Nothing) ppIt))
+        $+$ (if isNothing mElseTree
+                then empty
+                else text "else"
+                    $$ nest indentWith (ppCondTree (fromJust mElseTree)
+                        (if simplifiedPrinting then (Just it) else Nothing) ppIt))
+
+ppDeps :: [Dependency] -> Doc
+ppDeps []                                = empty
+ppDeps deps                              =
+    text "build-depends:" <+> fsep (punctuate comma (map disp deps))
+
+emptyLine :: Doc -> Doc
+emptyLine d                              = text " " $+$ d
+
+
+

Distribution/ParseUtils.hs

@@ -233,6 +233,7 @@ optsField name flavor get set =
         field name (hsep . map text)
                    (sepBy parseTokenQ' (munch1 isSpace))
   where
+        update _ opts l | and (map null opts)  = l
         update f opts [] = [(f,opts)]
         update f opts ((f',opts'):rest)
            | f == f'   = (f, opts' ++ opts) : rest
@@ -603,7 +604,7 @@ parseOptVersion = parseQuoted ver <++ ver
 
 parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)
 parseTestedWithQ = parseQuoted tw <++ tw
-  where 
+  where
     tw :: ReadP r (CompilerFlavor,VersionRange)
     tw = do compiler <- parseCompilerFlavorCompat
             skipSpaces
@@ -674,4 +675,14 @@ showTestedWith (compiler, version) = text (show compiler) <+> disp version
 -- | Pretty-print free-format text, ensuring that it is vertically aligned,
 -- and with blank lines replaced by dots for correct re-parsing.
 showFreeText :: String -> Doc
-showFreeText s = vcat [text (if null l then "." else l) | l <- lines s]
+showFreeText "" = empty
+showFreeText s  = vcat [text (if null l then "." else l) | l <- lines_ s]
+
+-- | 'lines_' breaks a string up into a list of strings at newline
+-- characters.  The resulting strings do not contain newlines.
+lines_                   :: String -> [String]
+lines_ []                =  [""]
+lines_ s                 =  let (l, s') = break (== '\n') s
+                            in  l : case s' of
+                                        []    -> []
+                                        (_:s'') -> lines_ s''