{-# 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) }