    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Distribution.PackageDescription.Parse
    -- Copyright   :  Isaac Jones 2003-2005
    -- License     :  BSD3
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- Portability :  portable
    --
    -- This defined parsers and partial pretty printers for the @.cabal@ format.
    -- Some of the complexity in this module is due to the fact that we have to be
    -- backwards compatible with old @.cabal@ files, so there's code to translate
    -- into the newer structure.

    module Distribution.PackageDescription.Parse (
            -- * Package descriptions
            readPackageDescription,
            writePackageDescription,
            parsePackageDescription,
            showPackageDescription,

            -- ** Parsing
            ParseResult(..),
            FieldDescr(..),
            LineNo,

            -- ** Supplementary build information
            readHookedBuildInfo,
            parseHookedBuildInfo,
            writeHookedBuildInfo,
            showHookedBuildInfo,

            pkgDescrFieldDescrs,
            libFieldDescrs,
            executableFieldDescrs,
            binfoFieldDescrs,
            sourceRepoFieldDescrs,
            testSuiteFieldDescrs,
            flagFieldDescrs
      ) where

    import Data.Char  (isSpace)
    import Data.Maybe (listToMaybe, isJust)
    #if __GLASGOW_HASKELL__ < 710
    import Data.Monoid ( Monoid(..) )
    #endif
    import Data.List  (nub, unfoldr, partition, (\\))
    import Control.Monad (liftM, foldM, when, unless, ap)
    #if __GLASGOW_HASKELL__ < 710
    import Control.Applicative (Applicative(..))
    #endif
    import Control.Arrow (first)
    import System.Directory (doesFileExist)
    import qualified Data.ByteString.Lazy.Char8 as BS.Char8
    import Data.Typeable
    import Data.Data
    import qualified Data.Map as Map

    import Distribution.Text
             ( Text(disp, parse), display, simpleParse )
    import Distribution.Compat.ReadP
             ((+++), option)
    import qualified Distribution.Compat.ReadP as Parse
    import Text.PrettyPrint

    import Distribution.ParseUtils hiding (parseFields)
    import Distribution.PackageDescription
    import Distribution.PackageDescription.Utils
             ( cabalBug, userBug )
    import Distribution.Package
             ( PackageIdentifier(..), Dependency(..), packageName, packageVersion )
    import Distribution.ModuleName ( ModuleName )
    import Distribution.Version
            ( Version(Version), orLaterVersion
            , LowerBound(..), asVersionIntervals )
    import Distribution.Verbosity (Verbosity)
    import Distribution.Compiler  (CompilerFlavor(..))
    import Distribution.PackageDescription.Configuration (parseCondition, freeVars)
    import Distribution.Simple.Utils
             ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion
             , withFileContents, withUTF8FileContents
             , writeFileAtomic, writeUTF8File )

    -- -----------------------------------------------------------------------------
    -- The PackageDescription type

    pkgDescrFieldDescrs :: [FieldDescr PackageDescription]
    pkgDescrFieldDescrs =
        [ simpleField "name"
               disp                   parse
               packageName            (\name pkg -> pkg{package=(package pkg){pkgName=name}})
     , simpleField "version"
               disp                   parse
               packageVersion         (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})
     , simpleField "cabal-version"
               (either disp disp)     (liftM Left parse +++ liftM Right parse)
               specVersionRaw         (\v pkg -> pkg{specVersionRaw=v})
     , simpleField "build-type"
               (maybe empty disp)     (fmap Just parse)
               buildType              (\t pkg -> pkg{buildType=t})
     , simpleField "license"
               disp                   parseLicenseQ
               license                (\l pkg -> pkg{license=l})
       -- We have both 'license-file' and 'license-files' fields.
       -- Rather than declaring license-file to be deprecated, we will continue
       -- to allow both. The 'license-file' will continue to only allow single
       -- tokens, while 'license-files' allows multiple. On pretty-printing, we
       -- will use 'license-file' if there's just one, and use 'license-files'
       -- otherwise.
     , simpleField "license-file"
               showFilePath           parseFilePathQ
               (\pkg -> case licenseFiles pkg of
                          [x] -> x
                          _   -> "")
               (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]})
     , listField "license-files"
               showFilePath           parseFilePathQ
               (\pkg -> case licenseFiles pkg of
                          [_] -> []
                          xs  -> xs)
               (\ls pkg -> pkg{licenseFiles=ls})
     , simpleField "copyright"
               showFreeText           parseFreeText
               copyright              (\val pkg -> pkg{copyright=val})
     , simpleField "maintainer"
               showFreeText           parseFreeText
               maintainer             (\val pkg -> pkg{maintainer=val})
     , simpleField "stability"
               showFreeText           parseFreeText
               stability              (\val pkg -> pkg{stability=val})
     , simpleField "homepage"
               showFreeText           parseFreeText
               homepage               (\val pkg -> pkg{homepage=val})
     , simpleField "package-url"
               showFreeText           parseFreeText
               pkgUrl                 (\val pkg -> pkg{pkgUrl=val})
     , simpleField "bug-reports"
               showFreeText           parseFreeText
               bugReports             (\val pkg -> pkg{bugReports=val})
     , simpleField "synopsis"
               showFreeText           parseFreeText
               synopsis               (\val pkg -> pkg{synopsis=val})
     , simpleField "description"
               showFreeText           parseFreeText
               description            (\val pkg -> pkg{description=val})
     , simpleField "category"
               showFreeText           parseFreeText
               category               (\val pkg -> pkg{category=val})
     , simpleField "author"
               showFreeText           parseFreeText
               author                 (\val pkg -> pkg{author=val})
     , listField "tested-with"
               showTestedWith         parseTestedWithQ
               testedWith             (\val pkg -> pkg{testedWith=val})
     , listFieldWithSep vcat "data-files"
               showFilePath           parseFilePathQ
               dataFiles              (\val pkg -> pkg{dataFiles=val})
     , simpleField "data-dir"
               showFilePath           parseFilePathQ
               dataDir                (\val pkg -> pkg{dataDir=val})
     , listFieldWithSep vcat "extra-source-files"
               showFilePath    parseFilePathQ
               extraSrcFiles          (\val pkg -> pkg{extraSrcFiles=val})
     , listFieldWithSep vcat "extra-tmp-files"
               showFilePath       parseFilePathQ
               extraTmpFiles          (\val pkg -> pkg{extraTmpFiles=val})
     , listFieldWithSep vcat "extra-doc-files"
               showFilePath    parseFilePathQ
               extraDocFiles          (\val pkg -> pkg{extraDocFiles=val})
     ]

    -- | 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 =
                   customFieldsPD pkg ++ [(f,val)]}
    storeXFieldsPD _ _ = Nothing

    -- ---------------------------------------------------------------------------
    -- The Library type

    libFieldDescrs :: [FieldDescr Library]
    libFieldDescrs =
      [ listFieldWithSep vcat "exposed-modules" disp parseModuleNameQ
          exposedModules (\mods lib -> lib{exposedModules=mods})

      , commaListFieldWithSep vcat "reexported-modules" disp parse
          reexportedModules (\mods lib -> lib{reexportedModules=mods})

      , listFieldWithSep vcat "required-signatures" disp parseModuleNameQ
          requiredSignatures (\mods lib -> lib{requiredSignatures=mods})

      , listFieldWithSep vcat "exposed-signatures" disp parseModuleNameQ
          exposedSignatures (\mods lib -> lib{exposedSignatures=mods})

      , boolField "exposed"
          libExposed     (\val lib -> lib{libExposed=val})
      ] ++ map biToLib binfoFieldDescrs
      where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi})

    storeXFieldsLib :: UnrecFieldParser Library
    storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =
        Just $ l {libBuildInfo =
                     bi{ customFieldsBI = customFieldsBI bi ++ [(f,val)]}}
    storeXFieldsLib _ _ = Nothing

    -- ---------------------------------------------------------------------------
    -- The Executable type

    executableFieldDescrs :: [FieldDescr Executable]
    executableFieldDescrs =
      [ -- note ordering: configuration must come first, for
        -- showPackageDescription.
        simpleField "executable"
                               showToken          parseTokenQ
                               exeName            (\xs    exe -> exe{exeName=xs})
      , simpleField "main-is"
                               showFilePath       parseFilePathQ
                               modulePath         (\xs    exe -> exe{modulePath=xs})
      ]
      ++ map biToExe binfoFieldDescrs
      where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi})

    storeXFieldsExe :: UnrecFieldParser Executable
    storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =
        Just $ e {buildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}}
    storeXFieldsExe _ _ = Nothing

    -- ---------------------------------------------------------------------------
    -- The TestSuite type

    -- | An intermediate type just used for parsing the test-suite stanza.
    -- After validation it is converted into the proper 'TestSuite' type.
    data TestSuiteStanza = TestSuiteStanza {
           testStanzaTestType   :: Maybe TestType,
           testStanzaMainIs     :: Maybe FilePath,
           testStanzaTestModule :: Maybe ModuleName,
           testStanzaBuildInfo  :: BuildInfo
         }

    emptyTestStanza :: TestSuiteStanza
    emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty

    testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza]
    testSuiteFieldDescrs =
        [ simpleField "type"
            (maybe empty disp)    (fmap Just parse)
            testStanzaTestType    (\x suite -> suite { testStanzaTestType = x })
        , simpleField "main-is"
            (maybe empty showFilePath)  (fmap Just parseFilePathQ)
            testStanzaMainIs      (\x suite -> suite { testStanzaMainIs = x })
        , simpleField "test-module"
            (maybe empty disp)    (fmap Just parseModuleNameQ)
            testStanzaTestModule  (\x suite -> suite { testStanzaTestModule = x })
        ]
        ++ map biToTest binfoFieldDescrs
      where
        biToTest = liftField testStanzaBuildInfo
                             (\bi suite -> suite { testStanzaBuildInfo = bi })

    storeXFieldsTest :: UnrecFieldParser TestSuiteStanza
    storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =
        Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}}
    storeXFieldsTest _ _ = Nothing

    validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite
    validateTestSuite line stanza =
        case testStanzaTestType stanza of
          Nothing -> return $
            emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza }

          Just tt@(TestTypeUnknown _ _) ->
            return emptyTestSuite {
              testInterface = TestSuiteUnsupported tt,
              testBuildInfo = testStanzaBuildInfo stanza
            }

          Just tt | tt `notElem` knownTestTypes ->
            return emptyTestSuite {
              testInterface = TestSuiteUnsupported tt,
              testBuildInfo = testStanzaBuildInfo stanza
            }

          Just tt@(TestTypeExe ver) ->
            case testStanzaMainIs stanza of
              Nothing   -> syntaxError line (missingField "main-is" tt)
              Just file -> do
                when (isJust (testStanzaTestModule stanza)) $
                  warning (extraField "test-module" tt)
                return emptyTestSuite {
                  testInterface = TestSuiteExeV10 ver file,
                  testBuildInfo = testStanzaBuildInfo stanza
                }

          Just tt@(TestTypeLib ver) ->
            case testStanzaTestModule stanza of
              Nothing      -> syntaxError line (missingField "test-module" tt)
              Just module_ -> do
                when (isJust (testStanzaMainIs stanza)) $
                  warning (extraField "main-is" tt)
                return emptyTestSuite {
                  testInterface = TestSuiteLibV09 ver module_,
                  testBuildInfo = testStanzaBuildInfo stanza
                }

      where
        missingField name tt = "The '" ++ name ++ "' field is required for the "
                            ++ display tt ++ " test suite type."

        extraField   name tt = "The '" ++ name ++ "' field is not used for the '"
                            ++ display tt ++ "' test suite type."

    -- ---------------------------------------------------------------------------
    -- The Benchmark type

    -- | An intermediate type just used for parsing the benchmark stanza.
    -- After validation it is converted into the proper 'Benchmark' type.
    data BenchmarkStanza = BenchmarkStanza {
           benchmarkStanzaBenchmarkType   :: Maybe BenchmarkType,
           benchmarkStanzaMainIs          :: Maybe FilePath,
           benchmarkStanzaBenchmarkModule :: Maybe ModuleName,
           benchmarkStanzaBuildInfo       :: BuildInfo
         }

    emptyBenchmarkStanza :: BenchmarkStanza
    emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty

    benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza]
    benchmarkFieldDescrs =
        [ simpleField "type"
            (maybe empty disp)    (fmap Just parse)
            benchmarkStanzaBenchmarkType
            (\x suite -> suite { benchmarkStanzaBenchmarkType = x })
        , simpleField "main-is"
            (maybe empty showFilePath)  (fmap Just parseFilePathQ)
            benchmarkStanzaMainIs
            (\x suite -> suite { benchmarkStanzaMainIs = x })
        ]
        ++ map biToBenchmark binfoFieldDescrs
      where
        biToBenchmark = liftField benchmarkStanzaBuildInfo
                        (\bi suite -> suite { benchmarkStanzaBuildInfo = bi })

    storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza
    storeXFieldsBenchmark (f@('x':'-':_), val)
        t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =
            Just $ t {benchmarkStanzaBuildInfo =
                           bi{ customFieldsBI = (f,val):customFieldsBI bi}}
    storeXFieldsBenchmark _ _ = Nothing

    validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark
    validateBenchmark line stanza =
        case benchmarkStanzaBenchmarkType stanza of
          Nothing -> return $
            emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza }

          Just tt@(BenchmarkTypeUnknown _ _) ->
            return emptyBenchmark {
              benchmarkInterface = BenchmarkUnsupported tt,
              benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
            }

          Just tt | tt `notElem` knownBenchmarkTypes ->
            return emptyBenchmark {
              benchmarkInterface = BenchmarkUnsupported tt,
              benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
            }

          Just tt@(BenchmarkTypeExe ver) ->
            case benchmarkStanzaMainIs stanza of
              Nothing   -> syntaxError line (missingField "main-is" tt)
              Just file -> do
                when (isJust (benchmarkStanzaBenchmarkModule stanza)) $
                  warning (extraField "benchmark-module" tt)
                return emptyBenchmark {
                  benchmarkInterface = BenchmarkExeV10 ver file,
                  benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
                }

      where
        missingField name tt = "The '" ++ name ++ "' field is required for the "
                            ++ display tt ++ " benchmark type."

        extraField   name tt = "The '" ++ name ++ "' field is not used for the '"
                            ++ display tt ++ "' benchmark type."

    -- ---------------------------------------------------------------------------
    -- The BuildInfo type

    binfoFieldDescrs :: [FieldDescr BuildInfo]
    binfoFieldDescrs =
     [ boolField "buildable"
               buildable          (\val binfo -> binfo{buildable=val})
     , commaListField  "build-tools"
               disp               parseBuildTool
               buildTools         (\xs  binfo -> binfo{buildTools=xs})
     , commaListFieldWithSep vcat "build-depends"
               disp                   parse
               buildDependsWithRenaming
               setBuildDependsWithRenaming
     , spaceListField "cpp-options"
               showToken          parseTokenQ'
               cppOptions          (\val binfo -> binfo{cppOptions=val})
     , spaceListField "cc-options"
               showToken          parseTokenQ'
               ccOptions          (\val binfo -> binfo{ccOptions=val})
     , spaceListField "ld-options"
               showToken          parseTokenQ'
               ldOptions          (\val binfo -> binfo{ldOptions=val})
     , commaListField  "pkgconfig-depends"
               disp               parsePkgconfigDependency
               pkgconfigDepends   (\xs  binfo -> binfo{pkgconfigDepends=xs})
     , listField "frameworks"
               showToken          parseTokenQ
               frameworks         (\val binfo -> binfo{frameworks=val})
     , listFieldWithSep vcat "c-sources"
               showFilePath       parseFilePathQ
               cSources           (\paths binfo -> binfo{cSources=paths})
     , listFieldWithSep vcat "js-sources"
               showFilePath       parseFilePathQ
               jsSources          (\paths binfo -> binfo{jsSources=paths})
     , simpleField "default-language"
               (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))
               defaultLanguage    (\lang  binfo -> binfo{defaultLanguage=lang})
     , listField   "other-languages"
               disp               parseLanguageQ
               otherLanguages     (\langs binfo -> binfo{otherLanguages=langs})
     , listField   "default-extensions"
               disp               parseExtensionQ
               defaultExtensions  (\exts  binfo -> binfo{defaultExtensions=exts})
     , listField   "other-extensions"
               disp               parseExtensionQ
               otherExtensions    (\exts  binfo -> binfo{otherExtensions=exts})
     , listField   "extensions"
               disp               parseExtensionQ
               oldExtensions      (\exts  binfo -> binfo{oldExtensions=exts})

     , listFieldWithSep vcat "extra-libraries"
               showToken          parseTokenQ
               extraLibs          (\xs    binfo -> binfo{extraLibs=xs})
     , listFieldWithSep vcat "extra-ghci-libraries"
               showToken          parseTokenQ
               extraGHCiLibs      (\xs    binfo -> binfo{extraGHCiLibs=xs})
     , listField   "extra-lib-dirs"
               showFilePath       parseFilePathQ
               extraLibDirs       (\xs    binfo -> binfo{extraLibDirs=xs})
     , listFieldWithSep vcat "includes"
               showFilePath       parseFilePathQ
               includes           (\paths binfo -> binfo{includes=paths})
     , listFieldWithSep vcat "install-includes"
               showFilePath       parseFilePathQ
               installIncludes    (\paths binfo -> binfo{installIncludes=paths})
     , listField   "include-dirs"
               showFilePath       parseFilePathQ
               includeDirs        (\paths binfo -> binfo{includeDirs=paths})
     , listField   "hs-source-dirs"
               showFilePath       parseFilePathQ
               hsSourceDirs       (\paths binfo -> binfo{hsSourceDirs=paths})
     , listFieldWithSep vcat "other-modules"
               disp               parseModuleNameQ
               otherModules       (\val binfo -> binfo{otherModules=val})
     , optsField   "ghc-prof-options" GHC
               profOptions        (\val binfo -> binfo{profOptions=val})
     , optsField   "ghcjs-prof-options" GHCJS
               profOptions        (\val binfo -> binfo{profOptions=val})
     , optsField   "ghc-shared-options" GHC
               sharedOptions      (\val binfo -> binfo{sharedOptions=val})
     , optsField   "ghcjs-shared-options" GHCJS
               sharedOptions      (\val binfo -> binfo{sharedOptions=val})
     , optsField   "ghc-options"  GHC
               options            (\path  binfo -> binfo{options=path})
     , optsField   "ghcjs-options" GHCJS
               options            (\path  binfo -> binfo{options=path})
     , optsField   "jhc-options"  JHC
               options            (\path  binfo -> binfo{options=path})

     -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept
     -- around for backwards compatibility.
     , optsField   "hugs-options" Hugs
               options            (const id)
     , optsField   "nhc98-options" NHC
               options            (const id)
     ]

    storeXFieldsBI :: UnrecFieldParser BuildInfo
    storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi }
    storeXFieldsBI _ _ = Nothing

    ------------------------------------------------------------------------------

    flagFieldDescrs :: [FieldDescr Flag]
    flagFieldDescrs =
        [ simpleField "description"
            showFreeText     parseFreeText
            flagDescription  (\val fl -> fl{ flagDescription = val })
        , boolField "default"
            flagDefault      (\val fl -> fl{ flagDefault = val })
        , boolField "manual"
            flagManual       (\val fl -> fl{ flagManual = val })
        ]

    ------------------------------------------------------------------------------

    sourceRepoFieldDescrs :: [FieldDescr SourceRepo]
    sourceRepoFieldDescrs =
        [ simpleField "type"
            (maybe empty disp)         (fmap Just parse)
            repoType                   (\val repo -> repo { repoType = val })
        , simpleField "location"
            (maybe empty showFreeText) (fmap Just parseFreeText)
            repoLocation               (\val repo -> repo { repoLocation = val })
        , simpleField "module"
            (maybe empty showToken)    (fmap Just parseTokenQ)
            repoModule                 (\val repo -> repo { repoModule = val })
        , simpleField "branch"
            (maybe empty showToken)    (fmap Just parseTokenQ)
            repoBranch                 (\val repo -> repo { repoBranch = val })
        , simpleField "tag"
            (maybe empty showToken)    (fmap Just parseTokenQ)
            repoTag                    (\val repo -> repo { repoTag = val })
        , simpleField "subdir"
            (maybe empty showFilePath) (fmap Just parseFilePathQ)
            repoSubdir                 (\val repo -> repo { repoSubdir = val })
        ]

    -- ---------------------------------------------------------------
    -- Parsing

    -- | Given a parser and a filename, return the parse of the file,
    -- after checking if the file exists.
    readAndParseFile :: (FilePath -> (String -> IO a) -> IO a)
                     -> (String -> ParseResult a)
                     -> Verbosity
                     -> FilePath -> IO a
    readAndParseFile withFileContents' parser verbosity fpath = do
      exists <- doesFileExist fpath
      unless exists
        (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")
      withFileContents' fpath $ \str -> case parser str of
        ParseFailed e -> do
            let (line, message) = locatedErrorMsg e
            dieWithLocation fpath line message
        ParseOk warnings x -> do
            mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings
            return x

    readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
    readHookedBuildInfo =
        readAndParseFile withFileContents parseHookedBuildInfo

    -- |Parse the given package file.
    readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
    readPackageDescription =
        readAndParseFile withUTF8FileContents parsePackageDescription

    stanzas :: [Field] -> [[Field]]
    stanzas [] = []
    stanzas (f:fields) = (f:this) : stanzas rest
      where
        (this, rest) = break isStanzaHeader fields

    isStanzaHeader :: Field -> Bool
    isStanzaHeader (F _ f _) = f == "executable"
    isStanzaHeader _ = False

    ------------------------------------------------------------------------------

    mapSimpleFields :: (Field -> ParseResult Field) -> [Field]
                    -> ParseResult [Field]
    mapSimpleFields f = mapM walk
      where
        walk fld@F{} = f fld
        walk (IfBlock l c fs1 fs2) = do
          fs1' <- mapM walk fs1
          fs2' <- mapM walk fs2
          return (IfBlock l c fs1' fs2')
        walk (Section ln n l fs1) = do
          fs1' <-  mapM walk fs1
          return (Section ln n l fs1')

    -- prop_isMapM fs = mapSimpleFields return fs == return fs

    -- names of fields that represents dependencies, thus consrca
    constraintFieldNames :: [String]
    constraintFieldNames = ["build-depends"]

    -- Possible refactoring would be to have modifiers be explicit about what
    -- they add and define an accessor that specifies what the dependencies
    -- are.  This way we would completely reuse the parsing knowledge from the
    -- field descriptor.
    parseConstraint :: Field -> ParseResult [DependencyWithRenaming]
    parseConstraint (F l n v)
        | n == "build-depends" = runP l n (parseCommaList parse) v
    parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")"

    {-
    headerFieldNames :: [String]
    headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames))
                     . map fieldName $ pkgDescrFieldDescrs
    -}

    libFieldNames :: [String]
    libFieldNames = map fieldName libFieldDescrs
                    ++ buildInfoNames ++ constraintFieldNames

    -- exeFieldNames :: [String]
    -- exeFieldNames = map fieldName executableFieldDescrs
    --                 ++ buildInfoNames

    buildInfoNames :: [String]
    buildInfoNames = map fieldName binfoFieldDescrs
                    ++ map fst deprecatedFieldsBuildInfo

    -- A minimal implementation of the StateT monad transformer to avoid depending
    -- on the 'mtl' package.
    newtype StT s m a = StT { runStT :: s -> m (a,s) }

    instance Functor f => Functor (StT s f) where
        fmap g (StT f) = StT $ fmap (first g)  . f

    instance (Monad m, Functor m) => Applicative (StT s m) where
        pure = return
        (<*>) = ap

    instance Monad m => Monad (StT s m) where
        return a = StT (\s -> return (a,s))
        StT f >>= g = StT $ \s -> do
                            (a,s') <- f s
                            runStT (g a) s'

    get :: Monad m => StT s m s
    get = StT $ \s -> return (s, s)

    modify :: Monad m => (s -> s) -> StT s m ()
    modify f = StT $ \s -> return ((),f s)

    lift :: Monad m => m a -> StT s m a
    lift m = StT $ \s -> m >>= \a -> return (a,s)

    evalStT :: Monad m => StT s m a -> s -> m a
    evalStT st s = liftM fst $ runStT st s

    -- Our monad for parsing a list/tree of fields.
    --
    -- The state represents the remaining fields to be processed.
    type PM a = StT [Field] ParseResult a

    -- return look-ahead field or nothing if we're at the end of the file
    peekField :: PM (Maybe Field)
    peekField = liftM listToMaybe get

    -- Unconditionally discard the first field in our state.  Will error when it
    -- reaches end of file.  (Yes, that's evil.)
    skipField :: PM ()
    skipField = modify tail

    --FIXME: this should take a ByteString, not a String. We have to be able to
    -- decode UTF8 and handle the BOM.

    -- | Parses the given file into a 'GenericPackageDescription'.
    --
    -- In Cabal 1.2 the syntax for package descriptions was changed to a format
    -- with sections and possibly indented property descriptions.
    parsePackageDescription :: String -> ParseResult GenericPackageDescription
    parsePackageDescription file = do

        -- This function is quite complex because it needs to be able to parse
        -- both pre-Cabal-1.2 and post-Cabal-1.2 files.  Additionally, it contains
        -- a lot of parser-related noise since we do not want to depend on Parsec.
        --
        -- If we detect an pre-1.2 file we implicitly convert it to post-1.2
        -- style.  See 'sectionizeFields' below for details about the conversion.

        fields0 <- readFields file `catchParseError` \err ->
                     let tabs = findIndentTabs file in
                     case err of
                       -- In case of a TabsError report them all at once.
                       TabsError tabLineNo -> reportTabsError
                       -- but only report the ones including and following
                       -- the one that caused the actual error
                                                [ t | t@(lineNo',_) <- tabs
                                                    , lineNo' >= tabLineNo ]
                       _ -> parseFail err

        let cabalVersionNeeded =
              head $ [ minVersionBound versionRange
                     | Just versionRange <- [ simpleParse v
                                            | F _ "cabal-version" v <- fields0 ] ]
                  ++ [Version [0] []]
            minVersionBound versionRange =
              case asVersionIntervals versionRange of
                []                            -> Version [0] []
                ((LowerBound version _, _):_) -> version

        handleFutureVersionParseFailure cabalVersionNeeded $ do

          let sf = sectionizeFields fields0  -- ensure 1.2 format

            -- figure out and warn about deprecated stuff (warnings are collected
            -- inside our parsing monad)
          fields <- mapSimpleFields deprecField sf

            -- Our parsing monad takes the not-yet-parsed fields as its state.
            -- After each successful parse we remove the field from the state
            -- ('skipField') and move on to the next one.
            --
            -- Things are complicated a bit, because fields take a tree-like
            -- structure -- they can be sections or "if"/"else" conditionals.

          flip evalStT fields $ do

              -- The header consists of all simple fields up to the first section
              -- (flag, library, executable).
            header_fields <- getHeader []

              -- Parses just the header fields and stores them in a
              -- 'PackageDescription'.  Note that our final result is a
              -- 'GenericPackageDescription'; for pragmatic reasons we just store
              -- the partially filled-out 'PackageDescription' inside the
              -- 'GenericPackageDescription'.
            pkg <- lift $ parseFields pkgDescrFieldDescrs
                                      storeXFieldsPD
                                      emptyPackageDescription
                                      header_fields

              -- 'getBody' assumes that the remaining fields only consist of
              -- flags, lib and exe sections.
            (repos, flags, mlib, exes, tests, bms) <- getBody
            warnIfRest  -- warn if getBody did not parse up to the last field.
              -- warn about using old/new syntax with wrong cabal-version:
            maybeWarnCabalVersion (not $ oldSyntax fields0) pkg
            checkForUndefinedFlags flags mlib exes tests
            return $ GenericPackageDescription
                       pkg { sourceRepos = repos }
                       flags mlib exes tests bms

      where
        oldSyntax = all isSimpleField
        reportTabsError tabs =
            syntaxError (fst (head tabs)) $
              "Do not use tabs for indentation (use spaces instead)\n"
              ++ "  Tabs were used at (line,column): " ++ show tabs

        maybeWarnCabalVersion newsyntax pkg
          | newsyntax && specVersion pkg < Version [1,2] []
          = lift $ warning $
                 "A package using section syntax must specify at least\n"
              ++ "'cabal-version: >= 1.2'."

        maybeWarnCabalVersion newsyntax pkg
          | not newsyntax && specVersion pkg >= Version [1,2] []
          = lift $ warning $
                 "A package using 'cabal-version: "
              ++ displaySpecVersion (specVersionRaw pkg)
              ++ "' must use section syntax. See the Cabal user guide for details."
          where
            displaySpecVersion (Left version)       = display version
            displaySpecVersion (Right versionRange) =
              case asVersionIntervals versionRange of
                [] {- impossible -}           -> display versionRange
                ((LowerBound version _, _):_) -> display (orLaterVersion version)

        maybeWarnCabalVersion _ _ = return ()

        handleFutureVersionParseFailure cabalVersionNeeded parseBody =
          (unless versionOk (warning message) >> parseBody)
            `catchParseError` \parseError -> case parseError of
            TabsError _   -> parseFail parseError
            _ | versionOk -> parseFail parseError
              | otherwise -> fail message
          where versionOk = cabalVersionNeeded <= cabalVersion
                message   = "This package requires at least Cabal version "
                         ++ display cabalVersionNeeded

        -- "Sectionize" an old-style Cabal file.  A sectionized file has:
        --
        --  * all global fields at the beginning, followed by
        --
        --  * all flag declarations, followed by
        --
        --  * an optional library section, and an arbitrary number of executable
        --    sections (in any order).
        --
        -- The current implementation just gathers all library-specific fields
        -- in a library section and wraps all executable stanzas in an executable
        -- section.
        sectionizeFields :: [Field] -> [Field]
        sectionizeFields fs
          | oldSyntax fs =
              let
                -- "build-depends" is a local field now.  To be backwards
                -- compatible, we still allow it as a global field in old-style
                -- package description files and translate it to a local field by
                -- adding it to every non-empty section
                (hdr0, exes0) = break ((=="executable") . fName) fs
                (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0

                (deps, libfs) = partition ((== "build-depends") . fName)
                                           libfs0

                exes = unfoldr toExe exes0
                toExe [] = Nothing
                toExe (F l e n : r)
                  | e == "executable" =
                      let (efs, r') = break ((=="executable") . fName) r
                      in Just (Section l "executable" n (deps ++ efs), r')
                toExe _ = cabalBug "unexpected input to 'toExe'"
              in
                hdr ++
               (if null libfs then []
                else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)])
                ++ exes
          | otherwise = fs

        isSimpleField F{} = True
        isSimpleField _ = False

        -- warn if there's something at the end of the file
        warnIfRest :: PM ()
        warnIfRest = do
          s <- get
          case s of
            [] -> return ()
            _ -> lift $ warning "Ignoring trailing declarations."  -- add line no.

        -- all simple fields at the beginning of the file are (considered) header
        -- fields
        getHeader :: [Field] -> PM [Field]
        getHeader acc = peekField >>= \mf -> case mf of
            Just f@F{} -> skipField >> getHeader (f:acc)
            _ -> return (reverse acc)

        --
        -- body ::= { repo | flag | library | executable | test }+   -- at most one lib
        --
        -- The body consists of an optional sequence of declarations of flags and
        -- an arbitrary number of executables and at most one library.
        getBody :: PM ([SourceRepo], [Flag]
                      ,Maybe (CondTree ConfVar [Dependency] Library)
                      ,[(String, CondTree ConfVar [Dependency] Executable)]
                      ,[(String, CondTree ConfVar [Dependency] TestSuite)]
                      ,[(String, CondTree ConfVar [Dependency] Benchmark)])
        getBody = peekField >>= \mf -> case mf of
          Just (Section line_no sec_type sec_label sec_fields)
            | sec_type == "executable" -> do
                when (null sec_label) $ lift $ syntaxError line_no
                  "'executable' needs one argument (the executable's name)"
                exename <- lift $ runP line_no "executable" parseTokenQ sec_label
                flds <- collectFields parseExeFields sec_fields
                skipField
                (repos, flags, lib, exes, tests, bms) <- getBody
                return (repos, flags, lib, (exename, flds): exes, tests, bms)

            | sec_type == "test-suite" -> do
                when (null sec_label) $ lift $ syntaxError line_no
                    "'test-suite' needs one argument (the test suite's name)"
                testname <- lift $ runP line_no "test" parseTokenQ sec_label
                flds <- collectFields (parseTestFields line_no) sec_fields

                -- Check that a valid test suite type has been chosen. A type
                -- field may be given inside a conditional block, so we must
                -- check for that before complaining that a type field has not
                -- been given. The test suite must always have a valid type, so
                -- we need to check both the 'then' and 'else' blocks, though
                -- the blocks need not have the same type.
                let checkTestType ts ct =
                        let ts' = mappend ts $ condTreeData ct
                            -- If a conditional has only a 'then' block and no
                            -- 'else' block, then it cannot have a valid type
                            -- in every branch, unless the type is specified at
                            -- a higher level in the tree.
                            checkComponent (_, _, Nothing) = False
                            -- If a conditional has a 'then' block and an 'else'
                            -- block, both must specify a test type, unless the
                            -- type is specified higher in the tree.
                            checkComponent (_, t, Just e) =
                                checkTestType ts' t && checkTestType ts' e
                            -- Does the current node specify a test type?
                            hasTestType = testInterface ts'
                                /= testInterface emptyTestSuite
                            components = condTreeComponents ct
                        -- If the current level of the tree specifies a type,
                        -- then we are done. If not, then one of the conditional
                        -- branches below the current node must specify a type.
                        -- Each node may have multiple immediate children; we
                        -- only one need one to specify a type because the
                        -- configure step uses 'mappend' to join together the
                        -- results of flag resolution.
                        in hasTestType || any checkComponent components
                if checkTestType emptyTestSuite flds
                    then do
                        skipField
                        (repos, flags, lib, exes, tests, bms) <- getBody
                        return (repos, flags, lib, exes, (testname, flds) : tests, bms)
                    else lift $ syntaxError line_no $
                             "Test suite \"" ++ testname
                          ++ "\" is missing required field \"type\" or the field "
                          ++ "is not present in all conditional branches. The "
                          ++ "available test types are: "
                          ++ intercalate ", " (map display knownTestTypes)

            | sec_type == "benchmark" -> do
                when (null sec_label) $ lift $ syntaxError line_no
                    "'benchmark' needs one argument (the benchmark's name)"
                benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label
                flds <- collectFields (parseBenchmarkFields line_no) sec_fields

                -- Check that a valid benchmark type has been chosen. A type
                -- field may be given inside a conditional block, so we must
                -- check for that before complaining that a type field has not
                -- been given. The benchmark must always have a valid type, so
                -- we need to check both the 'then' and 'else' blocks, though
                -- the blocks need not have the same type.
                let checkBenchmarkType ts ct =
                        let ts' = mappend ts $ condTreeData ct
                            -- If a conditional has only a 'then' block and no
                            -- 'else' block, then it cannot have a valid type
                            -- in every branch, unless the type is specified at
                            -- a higher level in the tree.
                            checkComponent (_, _, Nothing) = False
                            -- If a conditional has a 'then' block and an 'else'
                            -- block, both must specify a benchmark type, unless the
                            -- type is specified higher in the tree.
                            checkComponent (_, t, Just e) =
                                checkBenchmarkType ts' t && checkBenchmarkType ts' e
                            -- Does the current node specify a benchmark type?
                            hasBenchmarkType = benchmarkInterface ts'
                                /= benchmarkInterface emptyBenchmark
                            components = condTreeComponents ct
                        -- If the current level of the tree specifies a type,
                        -- then we are done. If not, then one of the conditional
                        -- branches below the current node must specify a type.
                        -- Each node may have multiple immediate children; we
                        -- only one need one to specify a type because the
                        -- configure step uses 'mappend' to join together the
                        -- results of flag resolution.
                        in hasBenchmarkType || any checkComponent components
                if checkBenchmarkType emptyBenchmark flds
                    then do
                        skipField
                        (repos, flags, lib, exes, tests, bms) <- getBody
                        return (repos, flags, lib, exes, tests, (benchname, flds) : bms)
                    else lift $ syntaxError line_no $
                             "Benchmark \"" ++ benchname
                          ++ "\" is missing required field \"type\" or the field "
                          ++ "is not present in all conditional branches. The "
                          ++ "available benchmark types are: "
                          ++ intercalate ", " (map display knownBenchmarkTypes)

            | sec_type == "library" -> do
                unless (null sec_label) $ lift $
                  syntaxError line_no "'library' expects no argument"
                flds <- collectFields parseLibFields sec_fields
                skipField
                (repos, flags, lib, exes, tests, bms) <- getBody
                when (isJust lib) $ lift $ syntaxError line_no
                  "There can only be one library section in a package description."
                return (repos, flags, Just flds, exes, tests, bms)

            | sec_type == "flag" -> do
                when (null sec_label) $ lift $
                  syntaxError line_no "'flag' needs one argument (the flag's name)"
                flag <- lift $ parseFields
                        flagFieldDescrs
                        warnUnrec
                        (MkFlag (FlagName (lowercase sec_label)) "" True False)
                        sec_fields
                skipField
                (repos, flags, lib, exes, tests, bms) <- getBody
                return (repos, flag:flags, lib, exes, tests, bms)

            | sec_type == "source-repository" -> do
                when (null sec_label) $ lift $ syntaxError line_no $
                     "'source-repository' needs one argument, "
                  ++ "the repo kind which is usually 'head' or 'this'"
                kind <- case simpleParse sec_label of
                  Just kind -> return kind
                  Nothing   -> lift $ syntaxError line_no $
                                 "could not parse repo kind: " ++ sec_label
                repo <- lift $ parseFields
                        sourceRepoFieldDescrs
                        warnUnrec
                        SourceRepo {
                          repoKind     = kind,
                          repoType     = Nothing,
                          repoLocation = Nothing,
                          repoModule   = Nothing,
                          repoBranch   = Nothing,
                          repoTag      = Nothing,
                          repoSubdir   = Nothing
                        }
                        sec_fields
                skipField
                (repos, flags, lib, exes, tests, bms) <- getBody
                return (repo:repos, flags, lib, exes, tests, bms)

            | otherwise -> do
                lift $ warning $ "Ignoring unknown section type: " ++ sec_type
                skipField
                getBody
          Just f@(F {}) -> do
                _ <- lift $ syntaxError (lineNo f) $
                  "Plain fields are not allowed in between stanzas: " ++ show f
                skipField
                getBody
          Just f@(IfBlock {}) -> do
                _ <- lift $ syntaxError (lineNo f) $
                  "If-blocks are not allowed in between stanzas: " ++ show f
                skipField
                getBody
          Nothing -> return ([], [], Nothing, [], [], [])

        -- Extracts all fields in a block and returns a 'CondTree'.
        --
        -- We have to recurse down into conditionals and we treat fields that
        -- describe dependencies specially.
        collectFields :: ([Field] -> PM a) -> [Field]
                      -> PM (CondTree ConfVar [Dependency] a)
        collectFields parser allflds = do

            let simplFlds = [ F l n v | F l n v <- allflds ]
                condFlds = [ f | f@IfBlock{} <- allflds ]
                sections = [ s | s@Section{} <- allflds ]

            -- Put these through the normal parsing pass too, so that we
            -- collect the ModRenamings
            let depFlds = filter isConstraint simplFlds

            mapM_
                (\(Section l n _ _) -> lift . warning $
                    "Unexpected section '" ++ n ++ "' on line " ++ show l)
                sections

            a <- parser simplFlds
            deps <- liftM concat . mapM (lift . fmap (map dependency) .  parseConstraint) $ depFlds

            ifs <- mapM processIfs condFlds

            return (CondNode a deps ifs)
          where
            isConstraint (F _ n _) = n `elem` constraintFieldNames
            isConstraint _ = False

            processIfs (IfBlock l c t e) = do
                cnd <- lift $ runP l "if" parseCondition c
                t' <- collectFields parser t
                e' <- case e of
                       [] -> return Nothing
                       es -> do fs <- collectFields parser es
                                return (Just fs)
                return (cnd, t', e')
            processIfs _ = cabalBug "processIfs called with wrong field type"

        parseLibFields :: [Field] -> PM Library
        parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary

        -- Note: we don't parse the "executable" field here, hence the tail hack.
        parseExeFields :: [Field] -> PM Executable
        parseExeFields = lift . parseFields (tail executableFieldDescrs)
                                            storeXFieldsExe emptyExecutable

        parseTestFields :: LineNo -> [Field] -> PM TestSuite
        parseTestFields line fields = do
            x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest
                                    emptyTestStanza fields
            lift $ validateTestSuite line x

        parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark
        parseBenchmarkFields line fields = do
            x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark
                                    emptyBenchmarkStanza fields
            lift $ validateBenchmark line x

        checkForUndefinedFlags ::
            [Flag] ->
            Maybe (CondTree ConfVar [Dependency] Library) ->
            [(String, CondTree ConfVar [Dependency] Executable)] ->
            [(String, CondTree ConfVar [Dependency] TestSuite)] ->
            PM ()
        checkForUndefinedFlags flags mlib exes tests = do
            let definedFlags = map flagName flags
            maybe (return ()) (checkCondTreeFlags definedFlags) mlib
            mapM_ (checkCondTreeFlags definedFlags . snd) exes
            mapM_ (checkCondTreeFlags definedFlags . snd) tests

        checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()
        checkCondTreeFlags definedFlags ct = do
            let fv = nub $ freeVars ct
            unless (all (`elem` definedFlags) fv) $
                fail $ "These flags are used without having been defined: "
                    ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]

    -- | Parse a list of fields, given a list of field descriptions,
    --   a structure to accumulate the parsed fields, and a function
    --   that can decide what to do with fields which don't match any
    --   of the field descriptions.
    parseFields :: [FieldDescr a]      -- ^ descriptions of fields we know how to
                                       --   parse
                -> UnrecFieldParser a  -- ^ possibly do something with
                                       --   unrecognized fields
                -> a                   -- ^ accumulator
                -> [Field]             -- ^ fields to be parsed
                -> ParseResult a
    parseFields descrs unrec ini fields =
        do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields
           unless (null unknowns) $ warning $ render $
             text "Unknown fields:" <+>
                  commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")
                                (reverse unknowns))
             $+$
             text "Fields allowed in this section:" $$
               nest 4 (commaSep $ map fieldName descrs)
           return a
      where
        commaSep = fsep . punctuate comma . map text

    parseField :: [FieldDescr a]     -- ^ list of parseable fields
               -> UnrecFieldParser a -- ^ possibly do something with
                                     --   unrecognized fields
               -> (a,[(Int,String)]) -- ^ accumulated result and warnings
               -> Field              -- ^ the field to be parsed
               -> ParseResult (a, [(Int,String)])
    parseField (FieldDescr name _ parser : fields) unrec (a, us) (F line f val)
      | name == f = parser line val a >>= \a' -> return (a',us)
      | otherwise = parseField fields unrec (a,us) (F line f val)
    parseField [] unrec (a,us) (F l f val) = return $
      case unrec (f,val) a of        -- no fields matched, see if the 'unrec'
        Just a' -> (a',us)           -- function wants to do anything with it
        Nothing -> (a, (l,f):us)
    parseField _ _ _ _ = cabalBug "'parseField' called on a non-field"

    deprecatedFields :: [(String,String)]
    deprecatedFields =
        deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo

    deprecatedFieldsPkgDescr :: [(String,String)]
    deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ]

    deprecatedFieldsBuildInfo :: [(String,String)]
    deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ]

    -- Handle deprecated fields
    deprecField :: Field -> ParseResult Field
    deprecField (F line fld val) = do
      fld' <- case lookup fld deprecatedFields of
                Nothing -> return fld
                Just newName -> do
                  warning $ "The field \"" ++ fld
                          ++ "\" is deprecated, please use \"" ++ newName ++ "\""
                  return newName
      return (F line fld' val)
    deprecField _ = cabalBug "'deprecField' called on a non-field"

    parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo
    parseHookedBuildInfo inp = do
      fields <- readFields inp
      let ss@(mLibFields:exes) = stanzas fields
      mLib <- parseLib mLibFields
      biExes <- mapM parseExe (maybe ss (const exes) mLib)
      return (mLib, biExes)
      where
        parseLib :: [Field] -> ParseResult (Maybe BuildInfo)
        parseLib (bi@(F _ inFieldName _:_))
            | lowercase inFieldName /= "executable" = liftM Just (parseBI bi)
        parseLib _ = return Nothing

        parseExe :: [Field] -> ParseResult (String, BuildInfo)
        parseExe (F line inFieldName mName:bi)
            | lowercase inFieldName == "executable"
                = do bis <- parseBI bi
                     return (mName, bis)
            | otherwise = syntaxError line "expecting 'executable' at top of stanza"
        parseExe (_:_) = cabalBug "`parseExe' called on a non-field"
        parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"

        parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st

    -- ---------------------------------------------------------------------------
    -- Pretty printing

    writePackageDescription :: FilePath -> PackageDescription -> IO ()
    writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)

    --TODO: make this use section syntax
    -- add equivalent for GenericPackageDescription
    showPackageDescription :: PackageDescription -> String
    showPackageDescription pkg = render $
         ppPackage pkg
      $$ ppCustomFields (customFieldsPD pkg)
      $$ (case library pkg of
            Nothing  -> empty
            Just lib -> ppLibrary lib)
      $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ]
      where
        ppPackage    = ppFields pkgDescrFieldDescrs
        ppLibrary    = ppFields libFieldDescrs
        ppExecutable = ppFields executableFieldDescrs

    ppCustomFields :: [(String,String)] -> Doc
    ppCustomFields flds = vcat (map ppCustomField flds)

    ppCustomField :: (String,String) -> Doc
    ppCustomField (name,val) = text name <> colon <+> showFreeText val

    writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
    writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
                                 . showHookedBuildInfo

    showHookedBuildInfo :: HookedBuildInfo -> String
    showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
         (case mb_lib_bi of
            Nothing -> empty
            Just bi -> ppBuildInfo bi)
      $$ vcat [    space
                $$ text "executable:" <+> text name
                $$ ppBuildInfo bi
              | (name, bi) <- ex_bis ]
      where
        ppBuildInfo bi = ppFields binfoFieldDescrs bi
                      $$ ppCustomFields (customFieldsBI bi)

    -- replace all tabs used as indentation with whitespace, also return where
    -- tabs were found
    findIndentTabs :: String -> [(Int,Int)]
    findIndentTabs = concatMap checkLine
                   . zip [1..]
                   . lines
        where
          checkLine (lineno, l) =
              let (indent, _content) = span isSpace l
                  tabCols = map fst . filter ((== '\t') . snd) . zip [0..]
                  addLineNo = map (\col -> (lineno,col))
              in addLineNo (tabCols indent)

    --test_findIndentTabs = findIndentTabs $ unlines $
    --    [ "foo", "  bar", " \t baz", "\t  biz\t", "\t\t \t mib" ]

    -- | Dependencies plus module renamings.  This is what users specify; however,
    -- renaming information is not used for dependency resolution.
    data DependencyWithRenaming = DependencyWithRenaming Dependency ModuleRenaming
      deriving (Read, Show, Eq, Typeable, Data)

    dependency :: DependencyWithRenaming -> Dependency
    dependency (DependencyWithRenaming dep _) = dep

    instance Text DependencyWithRenaming where
      disp (DependencyWithRenaming d rns) = disp d <+> disp rns
      parse = do d <- parse
                 Parse.skipSpaces
                 rns <- parse
                 Parse.skipSpaces
                 return (DependencyWithRenaming d rns)

    buildDependsWithRenaming :: BuildInfo -> [DependencyWithRenaming]
    buildDependsWithRenaming pkg =
        map (\dep@(Dependency n _) ->
                DependencyWithRenaming dep
                    (Map.findWithDefault defaultRenaming n (targetBuildRenaming pkg)))
            (targetBuildDepends pkg)

    setBuildDependsWithRenaming :: [DependencyWithRenaming] -> BuildInfo -> BuildInfo
    setBuildDependsWithRenaming deps pkg = pkg {
        targetBuildDepends = map dependency deps,
        targetBuildRenaming = Map.fromList (map (\(DependencyWithRenaming (Dependency n _) rns) -> (n, rns)) deps)
      }