module Distribution.PackageDescription.Parse (
readPackageDescription,
writePackageDescription,
parsePackageDescription,
showPackageDescription,
ParseResult(..),
FieldDescr(..),
LineNo,
readHookedBuildInfo,
parseHookedBuildInfo,
writeHookedBuildInfo,
showHookedBuildInfo,
pkgDescrFieldDescrs,
libFieldDescrs,
executableFieldDescrs,
binfoFieldDescrs,
sourceRepoFieldDescrs,
testSuiteFieldDescrs,
flagFieldDescrs
) where
import Data.Char (isSpace)
import Data.Maybe (listToMaybe, isJust)
import Data.Monoid ( Monoid(..) )
import Data.List (nub, unfoldr, partition, (\\))
import Control.Monad (liftM, foldM, when, unless, ap)
import Control.Applicative (Applicative(..))
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 )
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})
, 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})
]
storeXFieldsPD :: UnrecFieldParser PackageDescription
storeXFieldsPD (f@('x':'-':_),val) pkg =
Just pkg{ customFieldsPD =
customFieldsPD pkg ++ [(f,val)]}
storeXFieldsPD _ _ = Nothing
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
executableFieldDescrs :: [FieldDescr Executable]
executableFieldDescrs =
[
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
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."
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."
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})
, 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 })
]
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
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')
constraintFieldNames :: [String]
constraintFieldNames = ["build-depends"]
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 ++ ")"
libFieldNames :: [String]
libFieldNames = map fieldName libFieldDescrs
++ buildInfoNames ++ constraintFieldNames
buildInfoNames :: [String]
buildInfoNames = map fieldName binfoFieldDescrs
++ map fst deprecatedFieldsBuildInfo
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
type PM a = StT [Field] ParseResult a
peekField :: PM (Maybe Field)
peekField = liftM listToMaybe get
skipField :: PM ()
skipField = modify tail
parsePackageDescription :: String -> ParseResult GenericPackageDescription
parsePackageDescription file = do
fields0 <- readFields file `catchParseError` \err ->
let tabs = findIndentTabs file in
case err of
TabsError tabLineNo -> reportTabsError
[ 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
fields <- mapSimpleFields deprecField sf
flip evalStT fields $ do
header_fields <- getHeader []
pkg <- lift $ parseFields pkgDescrFieldDescrs
storeXFieldsPD
emptyPackageDescription
header_fields
(repos, flags, mlib, exes, tests, bms) <- getBody
warnIfRest
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
[] -> 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
sectionizeFields :: [Field] -> [Field]
sectionizeFields fs
| oldSyntax fs =
let
(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
warnIfRest :: PM ()
warnIfRest = do
s <- get
case s of
[] -> return ()
_ -> lift $ warning "Ignoring trailing declarations."
getHeader :: [Field] -> PM [Field]
getHeader acc = peekField >>= \mf -> case mf of
Just f@F{} -> skipField >> getHeader (f:acc)
_ -> return (reverse acc)
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
let checkTestType ts ct =
let ts' = mappend ts $ condTreeData ct
checkComponent (_, _, Nothing) = False
checkComponent (_, t, Just e) =
checkTestType ts' t && checkTestType ts' e
hasTestType = testInterface ts'
/= testInterface emptyTestSuite
components = condTreeComponents ct
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
let checkBenchmarkType ts ct =
let ts' = mappend ts $ condTreeData ct
checkComponent (_, _, Nothing) = False
checkComponent (_, t, Just e) =
checkBenchmarkType ts' t && checkBenchmarkType ts' e
hasBenchmarkType = benchmarkInterface ts'
/= benchmarkInterface emptyBenchmark
components = condTreeComponents ct
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, [], [], [])
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 ]
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
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 ]
parseFields :: [FieldDescr a]
-> UnrecFieldParser a
-> a
-> [Field]
-> 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]
-> UnrecFieldParser a
-> (a,[(Int,String)])
-> Field
-> 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
Just a' -> (a',us)
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") ]
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
writePackageDescription :: FilePath -> PackageDescription -> IO ()
writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)
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)
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)
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)
}