------------------------------------------------------------------------------- |-- Module : Distribution.PackageDescription.Parse-- Copyright : Isaac Jones 2003-2005---- Maintainer : [email protected]-- 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.{- All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Isaac Jones nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}moduleDistribution.PackageDescription.Parse(-- * Package descriptionsreadPackageDescription,writePackageDescription,parsePackageDescription,showPackageDescription,-- ** ParsingParseResult(..),FieldDescr(..),LineNo,-- ** Supplementary build informationreadHookedBuildInfo,parseHookedBuildInfo,writeHookedBuildInfo,showHookedBuildInfo,pkgDescrFieldDescrs,libFieldDescrs,executableFieldDescrs,binfoFieldDescrs,sourceRepoFieldDescrs,testSuiteFieldDescrs,flagFieldDescrs)whereimportData.Char(isSpace)importData.Maybe(listToMaybe,isJust)importData.Monoid(Monoid(..))importData.List(nub,unfoldr,partition,(\\))importControl.Monad(liftM,foldM,when,unless)importSystem.Directory(doesFileExist)importDistribution.Text(Text(disp,parse),display,simpleParse)importDistribution.Compat.ReadP((+++),option)importText.PrettyPrintimportDistribution.ParseUtilshiding(parseFields)importDistribution.PackageDescriptionimportDistribution.Package(PackageIdentifier(..),Dependency(..),packageName,packageVersion)importDistribution.ModuleName(ModuleName)importDistribution.Version(Version(Version),orLaterVersion,LowerBound(..),asVersionIntervals)importDistribution.Verbosity(Verbosity)importDistribution.Compiler(CompilerFlavor(..))importDistribution.PackageDescription.Configuration(parseCondition,freeVars)importDistribution.Simple.Utils(die,dieWithLocation,warn,intercalate,lowercase,cabalVersion,withFileContents,withUTF8FileContents,writeFileAtomic,writeUTF8File)-- ------------------------------------------------------------------------------- The PackageDescription typepkgDescrFieldDescrs::[FieldDescrPackageDescription]pkgDescrFieldDescrs=[simpleField"name"dispparsepackageName(\namepkg->pkg{package=(packagepkg){pkgName=name}}),simpleField"version"dispparsepackageVersion(\verpkg->pkg{package=(packagepkg){pkgVersion=ver}}),simpleField"cabal-version"(eitherdispdisp)(liftMLeftparse+++liftMRightparse)specVersionRaw(\vpkg->pkg{specVersionRaw=v}),simpleField"build-type"(maybeemptydisp)(fmapJustparse)buildType(\tpkg->pkg{buildType=t}),simpleField"license"dispparseLicenseQlicense(\lpkg->pkg{license=l}),simpleField"license-file"showFilePathparseFilePathQlicenseFile(\lpkg->pkg{licenseFile=l}),simpleField"copyright"showFreeTextparseFreeTextcopyright(\valpkg->pkg{copyright=val}),simpleField"maintainer"showFreeTextparseFreeTextmaintainer(\valpkg->pkg{maintainer=val}),commaListField"build-depends"dispparsebuildDepends(\xspkg->pkg{buildDepends=xs}),simpleField"stability"showFreeTextparseFreeTextstability(\valpkg->pkg{stability=val}),simpleField"homepage"showFreeTextparseFreeTexthomepage(\valpkg->pkg{homepage=val}),simpleField"package-url"showFreeTextparseFreeTextpkgUrl(\valpkg->pkg{pkgUrl=val}),simpleField"bug-reports"showFreeTextparseFreeTextbugReports(\valpkg->pkg{bugReports=val}),simpleField"synopsis"showFreeTextparseFreeTextsynopsis(\valpkg->pkg{synopsis=val}),simpleField"description"showFreeTextparseFreeTextdescription(\valpkg->pkg{description=val}),simpleField"category"showFreeTextparseFreeTextcategory(\valpkg->pkg{category=val}),simpleField"author"showFreeTextparseFreeTextauthor(\valpkg->pkg{author=val}),listField"tested-with"showTestedWithparseTestedWithQtestedWith(\valpkg->pkg{testedWith=val}),listField"data-files"showFilePathparseFilePathQdataFiles(\valpkg->pkg{dataFiles=val}),simpleField"data-dir"showFilePathparseFilePathQdataDir(\valpkg->pkg{dataDir=val}),listField"extra-source-files"showFilePathparseFilePathQextraSrcFiles(\valpkg->pkg{extraSrcFiles=val}),listField"extra-tmp-files"showFilePathparseFilePathQextraTmpFiles(\valpkg->pkg{extraTmpFiles=val})]-- | Store any fields beginning with "x-" in the customFields field of-- a PackageDescription. All other fields will generate a warning.storeXFieldsPD::UnrecFieldParserPackageDescriptionstoreXFieldsPD(f@('x':'-':_),val)pkg=Justpkg{customFieldsPD=(customFieldsPDpkg)++[(f,val)]}storeXFieldsPD__=Nothing-- ----------------------------------------------------------------------------- The Library typelibFieldDescrs::[FieldDescrLibrary]libFieldDescrs=[listField"exposed-modules"dispparseModuleNameQexposedModules(\modslib->lib{exposedModules=mods}),boolField"exposed"libExposed(\vallib->lib{libExposed=val})]++mapbiToLibbinfoFieldDescrswherebiToLib=liftFieldlibBuildInfo(\bilib->lib{libBuildInfo=bi})storeXFieldsLib::UnrecFieldParserLibrarystoreXFieldsLib(f@('x':'-':_),val)l@(Library{libBuildInfo=bi})=Just$l{libBuildInfo=bi{customFieldsBI=(customFieldsBIbi)++[(f,val)]}}storeXFieldsLib__=Nothing-- ----------------------------------------------------------------------------- The Executable typeexecutableFieldDescrs::[FieldDescrExecutable]executableFieldDescrs=[-- note ordering: configuration must come first, for-- showPackageDescription.simpleField"executable"showTokenparseTokenQexeName(\xsexe->exe{exeName=xs}),simpleField"main-is"showFilePathparseFilePathQmodulePath(\xsexe->exe{modulePath=xs})]++mapbiToExebinfoFieldDescrswherebiToExe=liftFieldbuildInfo(\biexe->exe{buildInfo=bi})storeXFieldsExe::UnrecFieldParserExecutablestoreXFieldsExe(f@('x':'-':_),val)e@(Executable{buildInfo=bi})=Just$e{buildInfo=bi{customFieldsBI=(f,val):(customFieldsBIbi)}}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.dataTestSuiteStanza=TestSuiteStanza{testStanzaTestType::MaybeTestType,testStanzaMainIs::MaybeFilePath,testStanzaTestModule::MaybeModuleName,testStanzaBuildInfo::BuildInfo}emptyTestStanza::TestSuiteStanzaemptyTestStanza=TestSuiteStanzaNothingNothingNothingmemptytestSuiteFieldDescrs::[FieldDescrTestSuiteStanza]testSuiteFieldDescrs=[simpleField"type"(maybeemptydisp)(fmapJustparse)testStanzaTestType(\xsuite->suite{testStanzaTestType=x}),simpleField"main-is"(maybeemptyshowFilePath)(fmapJustparseFilePathQ)testStanzaMainIs(\xsuite->suite{testStanzaMainIs=x}),simpleField"test-module"(maybeemptydisp)(fmapJustparseModuleNameQ)testStanzaTestModule(\xsuite->suite{testStanzaTestModule=x})]++mapbiToTestbinfoFieldDescrswherebiToTest=liftFieldtestStanzaBuildInfo(\bisuite->suite{testStanzaBuildInfo=bi})storeXFieldsTest::UnrecFieldParserTestSuiteStanzastoreXFieldsTest(f@('x':'-':_),val)t@(TestSuiteStanza{testStanzaBuildInfo=bi})=Just$t{testStanzaBuildInfo=bi{customFieldsBI=(f,val):(customFieldsBIbi)}}storeXFieldsTest__=NothingvalidateTestSuite::LineNo->TestSuiteStanza->ParseResultTestSuitevalidateTestSuitelinestanza=casetestStanzaTestTypestanzaofNothing->return$emptyTestSuite{testBuildInfo=testStanzaBuildInfostanza}Justtt@(TestTypeUnknown__)->returnemptyTestSuite{testInterface=TestSuiteUnsupportedtt,testBuildInfo=testStanzaBuildInfostanza}Justtt|tt`notElem`knownTestTypes->returnemptyTestSuite{testInterface=TestSuiteUnsupportedtt,testBuildInfo=testStanzaBuildInfostanza}Justtt@(TestTypeExever)->casetestStanzaMainIsstanzaofNothing->syntaxErrorline(missingField"main-is"tt)Justfile->dowhen(isJust(testStanzaTestModulestanza))$warning(extraField"test-module"tt)returnemptyTestSuite{testInterface=TestSuiteExeV10verfile,testBuildInfo=testStanzaBuildInfostanza}Justtt@(TestTypeLibver)->casetestStanzaTestModulestanzaofNothing->syntaxErrorline(missingField"test-module"tt)Justmodule_->dowhen(isJust(testStanzaMainIsstanza))$warning(extraField"main-is"tt)returnemptyTestSuite{testInterface=TestSuiteLibV09vermodule_,testBuildInfo=testStanzaBuildInfostanza}wheremissingFieldnamett="The '"++name++"' field is required for the "++displaytt++" test suite type."extraFieldnamett="The '"++name++"' field is not used for the '"++displaytt++"' 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.dataBenchmarkStanza=BenchmarkStanza{benchmarkStanzaBenchmarkType::MaybeBenchmarkType,benchmarkStanzaMainIs::MaybeFilePath,benchmarkStanzaBenchmarkModule::MaybeModuleName,benchmarkStanzaBuildInfo::BuildInfo}emptyBenchmarkStanza::BenchmarkStanzaemptyBenchmarkStanza=BenchmarkStanzaNothingNothingNothingmemptybenchmarkFieldDescrs::[FieldDescrBenchmarkStanza]benchmarkFieldDescrs=[simpleField"type"(maybeemptydisp)(fmapJustparse)benchmarkStanzaBenchmarkType(\xsuite->suite{benchmarkStanzaBenchmarkType=x}),simpleField"main-is"(maybeemptyshowFilePath)(fmapJustparseFilePathQ)benchmarkStanzaMainIs(\xsuite->suite{benchmarkStanzaMainIs=x})]++mapbiToBenchmarkbinfoFieldDescrswherebiToBenchmark=liftFieldbenchmarkStanzaBuildInfo(\bisuite->suite{benchmarkStanzaBuildInfo=bi})storeXFieldsBenchmark::UnrecFieldParserBenchmarkStanzastoreXFieldsBenchmark(f@('x':'-':_),val)t@(BenchmarkStanza{benchmarkStanzaBuildInfo=bi})=Just$t{benchmarkStanzaBuildInfo=bi{customFieldsBI=(f,val):(customFieldsBIbi)}}storeXFieldsBenchmark__=NothingvalidateBenchmark::LineNo->BenchmarkStanza->ParseResultBenchmarkvalidateBenchmarklinestanza=casebenchmarkStanzaBenchmarkTypestanzaofNothing->return$emptyBenchmark{benchmarkBuildInfo=benchmarkStanzaBuildInfostanza}Justtt@(BenchmarkTypeUnknown__)->returnemptyBenchmark{benchmarkInterface=BenchmarkUnsupportedtt,benchmarkBuildInfo=benchmarkStanzaBuildInfostanza}Justtt|tt`notElem`knownBenchmarkTypes->returnemptyBenchmark{benchmarkInterface=BenchmarkUnsupportedtt,benchmarkBuildInfo=benchmarkStanzaBuildInfostanza}Justtt@(BenchmarkTypeExever)->casebenchmarkStanzaMainIsstanzaofNothing->syntaxErrorline(missingField"main-is"tt)Justfile->dowhen(isJust(benchmarkStanzaBenchmarkModulestanza))$warning(extraField"benchmark-module"tt)returnemptyBenchmark{benchmarkInterface=BenchmarkExeV10verfile,benchmarkBuildInfo=benchmarkStanzaBuildInfostanza}wheremissingFieldnamett="The '"++name++"' field is required for the "++displaytt++" benchmark type."extraFieldnamett="The '"++name++"' field is not used for the '"++displaytt++"' benchmark type."-- ----------------------------------------------------------------------------- The BuildInfo typebinfoFieldDescrs::[FieldDescrBuildInfo]binfoFieldDescrs=[boolField"buildable"buildable(\valbinfo->binfo{buildable=val}),commaListField"build-tools"dispparseBuildToolbuildTools(\xsbinfo->binfo{buildTools=xs}),spaceListField"cpp-options"showTokenparseTokenQ'cppOptions(\valbinfo->binfo{cppOptions=val}),spaceListField"cc-options"showTokenparseTokenQ'ccOptions(\valbinfo->binfo{ccOptions=val}),spaceListField"ld-options"showTokenparseTokenQ'ldOptions(\valbinfo->binfo{ldOptions=val}),commaListField"pkgconfig-depends"dispparsePkgconfigDependencypkgconfigDepends(\xsbinfo->binfo{pkgconfigDepends=xs}),listField"frameworks"showTokenparseTokenQframeworks(\valbinfo->binfo{frameworks=val}),listField"c-sources"showFilePathparseFilePathQcSources(\pathsbinfo->binfo{cSources=paths}),simpleField"default-language"(maybeemptydisp)(optionNothing(fmapJustparseLanguageQ))defaultLanguage(\langbinfo->binfo{defaultLanguage=lang}),listField"other-languages"dispparseLanguageQotherLanguages(\langsbinfo->binfo{otherLanguages=langs}),listField"default-extensions"dispparseExtensionQdefaultExtensions(\extsbinfo->binfo{defaultExtensions=exts}),listField"other-extensions"dispparseExtensionQotherExtensions(\extsbinfo->binfo{otherExtensions=exts}),listField"extensions"dispparseExtensionQoldExtensions(\extsbinfo->binfo{oldExtensions=exts}),listField"extra-libraries"showTokenparseTokenQextraLibs(\xsbinfo->binfo{extraLibs=xs}),listField"extra-lib-dirs"showFilePathparseFilePathQextraLibDirs(\xsbinfo->binfo{extraLibDirs=xs}),listField"includes"showFilePathparseFilePathQincludes(\pathsbinfo->binfo{includes=paths}),listField"install-includes"showFilePathparseFilePathQinstallIncludes(\pathsbinfo->binfo{installIncludes=paths}),listField"include-dirs"showFilePathparseFilePathQincludeDirs(\pathsbinfo->binfo{includeDirs=paths}),listField"hs-source-dirs"showFilePathparseFilePathQhsSourceDirs(\pathsbinfo->binfo{hsSourceDirs=paths}),listField"other-modules"dispparseModuleNameQotherModules(\valbinfo->binfo{otherModules=val}),listField"ghc-prof-options"textparseTokenQghcProfOptions(\valbinfo->binfo{ghcProfOptions=val}),listField"ghc-shared-options"textparseTokenQghcSharedOptions(\valbinfo->binfo{ghcSharedOptions=val}),optsField"ghc-options"GHCoptions(\pathbinfo->binfo{options=path}),optsField"hugs-options"Hugsoptions(\pathbinfo->binfo{options=path}),optsField"nhc98-options"NHCoptions(\pathbinfo->binfo{options=path}),optsField"jhc-options"JHCoptions(\pathbinfo->binfo{options=path})]storeXFieldsBI::UnrecFieldParserBuildInfostoreXFieldsBI(f@('x':'-':_),val)bi=Justbi{customFieldsBI=(f,val):(customFieldsBIbi)}storeXFieldsBI__=Nothing------------------------------------------------------------------------------flagFieldDescrs::[FieldDescrFlag]flagFieldDescrs=[simpleField"description"showFreeTextparseFreeTextflagDescription(\valfl->fl{flagDescription=val}),boolField"default"flagDefault(\valfl->fl{flagDefault=val}),boolField"manual"flagManual(\valfl->fl{flagManual=val})]------------------------------------------------------------------------------sourceRepoFieldDescrs::[FieldDescrSourceRepo]sourceRepoFieldDescrs=[simpleField"type"(maybeemptydisp)(fmapJustparse)repoType(\valrepo->repo{repoType=val}),simpleField"location"(maybeemptyshowFreeText)(fmapJustparseFreeText)repoLocation(\valrepo->repo{repoLocation=val}),simpleField"module"(maybeemptyshowToken)(fmapJustparseTokenQ)repoModule(\valrepo->repo{repoModule=val}),simpleField"branch"(maybeemptyshowToken)(fmapJustparseTokenQ)repoBranch(\valrepo->repo{repoBranch=val}),simpleField"tag"(maybeemptyshowToken)(fmapJustparseTokenQ)repoTag(\valrepo->repo{repoTag=val}),simpleField"subdir"(maybeemptyshowFilePath)(fmapJustparseFilePathQ)repoSubdir(\valrepo->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->IOa)->IOa)->(String->ParseResulta)->Verbosity->FilePath->IOareadAndParseFilewithFileContents'parserverbosityfpath=doexists<-doesFileExistfpathwhen(notexists)(die$"Error Parsing: file \""++fpath++"\" doesn't exist. Cannot continue.")withFileContents'fpath$\str->caseparserstrofParseFailede->dolet(line,message)=locatedErrorMsgedieWithLocationfpathlinemessageParseOkwarningsx->domapM_(warnverbosity.showPWarningfpath)$reversewarningsreturnxreadHookedBuildInfo::Verbosity->FilePath->IOHookedBuildInforeadHookedBuildInfo=readAndParseFilewithFileContentsparseHookedBuildInfo-- |Parse the given package file.readPackageDescription::Verbosity->FilePath->IOGenericPackageDescriptionreadPackageDescription=readAndParseFilewithUTF8FileContentsparsePackageDescriptionstanzas::[Field]->[[Field]]stanzas[]=[]stanzas(f:fields)=(f:this):stanzasrestwhere(this,rest)=breakisStanzaHeaderfieldsisStanzaHeader::Field->BoolisStanzaHeader(F_f_)=f=="executable"isStanzaHeader_=False------------------------------------------------------------------------------mapSimpleFields::(Field->ParseResultField)->[Field]->ParseResult[Field]mapSimpleFieldsffs=mapMwalkfswherewalkfld@(F___)=ffldwalk(IfBlocklcfs1fs2)=dofs1'<-mapMwalkfs1fs2'<-mapMwalkfs2return(IfBlocklcfs1'fs2')walk(Sectionlnnlfs1)=dofs1'<-mapMwalkfs1return(Sectionlnnlfs1')-- prop_isMapM fs = mapSimpleFields return fs == return fs-- names of fields that represents dependencies, thus consrcaconstraintFieldNames::[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[Dependency]parseConstraint(Flnv)|n=="build-depends"=runPln(parseCommaListparse)vparseConstraintf=bug$"Constraint was expected (got: "++showf++")"{-
headerFieldNames :: [String]
headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames))
. map fieldName $ pkgDescrFieldDescrs
-}libFieldNames::[String]libFieldNames=mapfieldNamelibFieldDescrs++buildInfoNames++constraintFieldNames-- exeFieldNames :: [String]-- exeFieldNames = map fieldName executableFieldDescrs-- ++ buildInfoNamesbuildInfoNames::[String]buildInfoNames=mapfieldNamebinfoFieldDescrs++mapfstdeprecatedFieldsBuildInfo-- A minimal implementation of the StateT monad transformer to avoid depending-- on the 'mtl' package.newtypeStTsma=StT{runStT::s->m(a,s)}instanceMonadm=>Monad(StTsm)wherereturna=StT(\s->return(a,s))StTf>>=g=StT$\s->do(a,s')<-fsrunStT(ga)s'get::Monadm=>StTsmsget=StT$\s->return(s,s)modify::Monadm=>(s->s)->StTsm()modifyf=StT$\s->return((),fs)lift::Monadm=>ma->StTsmaliftm=StT$\s->m>>=\a->return(a,s)evalStT::Monadm=>StTsma->s->maevalStTsts=runStTsts>>=return.fst-- Our monad for parsing a list/tree of fields.---- The state represents the remaining fields to be processed.typePMa=StT[Field]ParseResulta-- return look-ahead field or nothing if we're at the end of the filepeekField::PM(MaybeField)peekField=get>>=return.listToMaybe-- Unconditionally discard the first field in our state. Will error when it-- reaches end of file. (Yes, that's evil.)skipField::PM()skipField=modifytail--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->ParseResultGenericPackageDescriptionparsePackageDescriptionfile=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<-readFieldsfile`catchParseError`\err->lettabs=findIndentTabsfileincaseerrof-- In case of a TabsError report them all at once.TabsErrortabLineNo->reportTabsError-- but only report the ones including and following-- the one that caused the actual error[t|t@(lineNo',_)<-tabs,lineNo'>=tabLineNo]_->parseFailerrletcabalVersionNeeded=head$[minVersionBoundversionRange|JustversionRange<-[simpleParsev|F_"cabal-version"v<-fields0]]++[Version[0][]]minVersionBoundversionRange=caseasVersionIntervalsversionRangeof[]->Version[0][]((LowerBoundversion_,_):_)->versionhandleFutureVersionParseFailurecabalVersionNeeded$doletsf=sectionizeFieldsfields0-- ensure 1.2 format-- figure out and warn about deprecated stuff (warnings are collected-- inside our parsing monad)fields<-mapSimpleFieldsdeprecFieldsf-- 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.flipevalStTfields$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$parseFieldspkgDescrFieldDescrsstoreXFieldsPDemptyPackageDescriptionheader_fields-- 'getBody' assumes that the remaining fields only consist of-- flags, lib and exe sections.(repos,flags,mlib,exes,tests,bms)<-getBodywarnIfRest-- warn if getBody did not parse up to the last field.-- warn about using old/new syntax with wrong cabal-version:maybeWarnCabalVersion(not$oldSyntaxfields0)pkgcheckForUndefinedFlagsflagsmlibexestestsreturn$GenericPackageDescriptionpkg{sourceRepos=repos}flagsmlibexestestsbmswhereoldSyntaxflds=allisSimpleFieldfldsreportTabsErrortabs=syntaxError(fst(headtabs))$"Do not use tabs for indentation (use spaces instead)\n"++" Tabs were used at (line,column): "++showtabsmaybeWarnCabalVersionnewsyntaxpkg|newsyntax&&specVersionpkg<Version[1,2][]=lift$warning$"A package using section syntax must specify at least\n"++"'cabal-version: >= 1.2'."maybeWarnCabalVersionnewsyntaxpkg|notnewsyntax&&specVersionpkg>=Version[1,2][]=lift$warning$"A package using 'cabal-version: "++displaySpecVersion(specVersionRawpkg)++"' must use section syntax. See the Cabal user guide for details."wheredisplaySpecVersion(Leftversion)=displayversiondisplaySpecVersion(RightversionRange)=caseasVersionIntervalsversionRangeof[]{- impossible -}->displayversionRange((LowerBoundversion_,_):_)->display(orLaterVersionversion)maybeWarnCabalVersion__=return()handleFutureVersionParseFailurecabalVersionNeededparseBody=(unlessversionOk(warningmessage)>>parseBody)`catchParseError`\parseError->caseparseErrorofTabsError_->parseFailparseError_|versionOk->parseFailparseError|otherwise->failmessagewhereversionOk=cabalVersionNeeded<=cabalVersionmessage="This package requires at least Cabal version "++displaycabalVersionNeeded-- "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 implementatition just gathers all library-specific fields-- in a library section and wraps all executable stanzas in an executable-- section.sectionizeFields::[Field]->[Field]sectionizeFieldsfs|oldSyntaxfs=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)libfs0exes=unfoldrtoExeexes0toExe[]=NothingtoExe(Flen:r)|e=="executable"=let(efs,r')=break((=="executable").fName)rinJust(Sectionl"executable"n(deps++efs),r')toExe_=bug"unexpeced input to 'toExe'"inhdr++(ifnulllibfsthen[]else[Section(lineNo(headlibfs))"library"""(deps++libfs)])++exes|otherwise=fsisSimpleField(F___)=TrueisSimpleField_=False-- warn if there's something at the end of the filewarnIfRest::PM()warnIfRest=dos<-getcasesof[]->return()_->lift$warning"Ignoring trailing declarations."-- add line no.-- all simple fields at the beginning of the file are (considered) header-- fieldsgetHeader::[Field]->PM[Field]getHeaderacc=peekField>>=\mf->casemfofJustf@(F___)->skipField>>getHeader(f:acc)_->return(reverseacc)---- 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(CondTreeConfVar[Dependency]Library),[(String,CondTreeConfVar[Dependency]Executable)],[(String,CondTreeConfVar[Dependency]TestSuite)],[(String,CondTreeConfVar[Dependency]Benchmark)])getBody=peekField>>=\mf->casemfofJust(Sectionline_nosec_typesec_labelsec_fields)|sec_type=="executable"->dowhen(nullsec_label)$lift$syntaxErrorline_no"'executable' needs one argument (the executable's name)"exename<-lift$runPline_no"executable"parseTokenQsec_labelflds<-collectFieldsparseExeFieldssec_fieldsskipField(repos,flags,lib,exes,tests,bms)<-getBodyreturn(repos,flags,lib,(exename,flds):exes,tests,bms)|sec_type=="test-suite"->dowhen(nullsec_label)$lift$syntaxErrorline_no"'test-suite' needs one argument (the test suite's name)"testname<-lift$runPline_no"test"parseTokenQsec_labelflds<-collectFields(parseTestFieldsline_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.letcheckTestTypetsct=letts'=mappendts$condTreeDatact-- 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,Juste)=checkTestTypets't&&checkTestTypets'e-- Does the current node specify a test type?hasTestType=testInterfacets'/=testInterfaceemptyTestSuitecomponents=condTreeComponentsct-- 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.inhasTestType||(anycheckComponentcomponents)ifcheckTestTypeemptyTestSuitefldsthendoskipField(repos,flags,lib,exes,tests,bms)<-getBodyreturn(repos,flags,lib,exes,(testname,flds):tests,bms)elselift$syntaxErrorline_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", "(mapdisplayknownTestTypes)|sec_type=="benchmark"->dowhen(nullsec_label)$lift$syntaxErrorline_no"'benchmark' needs one argument (the benchmark's name)"benchname<-lift$runPline_no"benchmark"parseTokenQsec_labelflds<-collectFields(parseBenchmarkFieldsline_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.letcheckBenchmarkTypetsct=letts'=mappendts$condTreeDatact-- 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,Juste)=checkBenchmarkTypets't&&checkBenchmarkTypets'e-- Does the current node specify a benchmark type?hasBenchmarkType=benchmarkInterfacets'/=benchmarkInterfaceemptyBenchmarkcomponents=condTreeComponentsct-- 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.inhasBenchmarkType||(anycheckComponentcomponents)ifcheckBenchmarkTypeemptyBenchmarkfldsthendoskipField(repos,flags,lib,exes,tests,bms)<-getBodyreturn(repos,flags,lib,exes,tests,(benchname,flds):bms)elselift$syntaxErrorline_no$"Benchmark \""++benchname++"\" is missing required field \"type\" or the field "++"is not present in all conditional branches. The "++"available benchmark types are: "++intercalate", "(mapdisplayknownBenchmarkTypes)|sec_type=="library"->dowhen(not(nullsec_label))$lift$syntaxErrorline_no"'library' expects no argument"flds<-collectFieldsparseLibFieldssec_fieldsskipField(repos,flags,lib,exes,tests,bms)<-getBodywhen(isJustlib)$lift$syntaxErrorline_no"There can only be one library section in a package description."return(repos,flags,Justflds,exes,tests,bms)|sec_type=="flag"->dowhen(nullsec_label)$lift$syntaxErrorline_no"'flag' needs one argument (the flag's name)"flag<-lift$parseFieldsflagFieldDescrswarnUnrec(MkFlag(FlagName(lowercasesec_label))""TrueFalse)sec_fieldsskipField(repos,flags,lib,exes,tests,bms)<-getBodyreturn(repos,flag:flags,lib,exes,tests,bms)|sec_type=="source-repository"->dowhen(nullsec_label)$lift$syntaxErrorline_no$"'source-repository' needs one argument, "++"the repo kind which is usually 'head' or 'this'"kind<-casesimpleParsesec_labelofJustkind->returnkindNothing->lift$syntaxErrorline_no$"could not parse repo kind: "++sec_labelrepo<-lift$parseFieldssourceRepoFieldDescrswarnUnrec(SourceRepo{repoKind=kind,repoType=Nothing,repoLocation=Nothing,repoModule=Nothing,repoBranch=Nothing,repoTag=Nothing,repoSubdir=Nothing})sec_fieldsskipField(repos,flags,lib,exes,tests,bms)<-getBodyreturn(repo:repos,flags,lib,exes,tests,bms)|otherwise->dolift$warning$"Ignoring unknown section type: "++sec_typeskipFieldgetBodyJustf->do_<-lift$syntaxError(lineNof)$"Construct not supported at this position: "++showfskipFieldgetBodyNothing->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]->PMa)->[Field]->PM(CondTreeConfVar[Dependency]a)collectFieldsparserallflds=doletsimplFlds=[Flnv|Flnv<-allflds]condFlds=[f|f@(IfBlock____)<-allflds]let(depFlds,dataFlds)=partitionisConstraintsimplFldsa<-parserdataFldsdeps<-liftMconcat.mapM(lift.parseConstraint)$depFldsifs<-mapMprocessIfscondFldsreturn(CondNodeadepsifs)whereisConstraint(F_n_)=n`elem`constraintFieldNamesisConstraint_=FalseprocessIfs(IfBlocklcte)=docnd<-lift$runPl"if"parseConditionct'<-collectFieldsparserte'<-caseeof[]->returnNothinges->dofs<-collectFieldsparseresreturn(Justfs)return(cnd,t',e')processIfs_=bug"processIfs called with wrong field type"parseLibFields::[Field]->PMLibraryparseLibFields=lift.parseFieldslibFieldDescrsstoreXFieldsLibemptyLibrary-- Note: we don't parse the "executable" field here, hence the tail hack.parseExeFields::[Field]->PMExecutableparseExeFields=lift.parseFields(tailexecutableFieldDescrs)storeXFieldsExeemptyExecutableparseTestFields::LineNo->[Field]->PMTestSuiteparseTestFieldslinefields=dox<-lift$parseFieldstestSuiteFieldDescrsstoreXFieldsTestemptyTestStanzafieldslift$validateTestSuitelinexparseBenchmarkFields::LineNo->[Field]->PMBenchmarkparseBenchmarkFieldslinefields=dox<-lift$parseFieldsbenchmarkFieldDescrsstoreXFieldsBenchmarkemptyBenchmarkStanzafieldslift$validateBenchmarklinexcheckForUndefinedFlags::[Flag]->Maybe(CondTreeConfVar[Dependency]Library)->[(String,CondTreeConfVar[Dependency]Executable)]->[(String,CondTreeConfVar[Dependency]TestSuite)]->PM()checkForUndefinedFlagsflagsmlibexestests=doletdefinedFlags=mapflagNameflagsmaybe(return())(checkCondTreeFlagsdefinedFlags)mlibmapM_(checkCondTreeFlagsdefinedFlags.snd)exesmapM_(checkCondTreeFlagsdefinedFlags.snd)testscheckCondTreeFlags::[FlagName]->CondTreeConfVarca->PM()checkCondTreeFlagsdefinedFlagsct=doletfv=nub$freeVarsctwhen(not.all(`elem`definedFlags)$fv)$fail$"These flags are used without having been defined: "++intercalate", "[n|FlagNamen<-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::[FieldDescra]-- ^ descriptions of fields we know how to-- parse->UnrecFieldParsera-- ^ possibly do something with-- unrecognized fields->a-- ^ accumulator->[Field]-- ^ fields to be parsed->ParseResultaparseFieldsdescrsunrecinifields=do(a,unknowns)<-foldM(parseFielddescrsunrec)(ini,[])fieldswhen(not(nullunknowns))$dowarning$render$text"Unknown fields:"<+>commaSep(map(\(l,u)->u++" (line "++showl++")")(reverseunknowns))$+$text"Fields allowed in this section:"$$nest4(commaSep$mapfieldNamedescrs)returnawherecommaSep=fsep.punctuatecomma.maptextparseField::[FieldDescra]-- ^ list of parseable fields->UnrecFieldParsera-- ^ possibly do something with-- unrecognized fields->(a,[(Int,String)])-- ^ accumulated result and warnings->Field-- ^ the field to be parsed->ParseResult(a,[(Int,String)])parseField((FieldDescrname_parser):fields)unrec(a,us)(Flinefval)|name==f=parserlinevala>>=\a'->return(a',us)|otherwise=parseFieldfieldsunrec(a,us)(Flinefval)parseField[]unrec(a,us)(Flfval)=return$caseunrec(f,val)aof-- no fields matched, see if the 'unrec'Justa'->(a',us)-- function wants to do anything with itNothing->(a,((l,f):us))parseField____=bug"'parseField' called on a non-field"deprecatedFields::[(String,String)]deprecatedFields=deprecatedFieldsPkgDescr++deprecatedFieldsBuildInfodeprecatedFieldsPkgDescr::[(String,String)]deprecatedFieldsPkgDescr=[("other-files","extra-source-files")]deprecatedFieldsBuildInfo::[(String,String)]deprecatedFieldsBuildInfo=[("hs-source-dir","hs-source-dirs")]-- Handle deprecated fieldsdeprecField::Field->ParseResultFielddeprecField(Flinefldval)=dofld'<-caselookupflddeprecatedFieldsofNothing->returnfldJustnewName->dowarning$"The field \""++fld++"\" is deprecated, please use \""++newName++"\""returnnewNamereturn(Flinefld'val)deprecField_=bug"'deprecField' called on a non-field"parseHookedBuildInfo::String->ParseResultHookedBuildInfoparseHookedBuildInfoinp=dofields<-readFieldsinpletss@(mLibFields:exes)=stanzasfieldsmLib<-parseLibmLibFieldsbiExes<-mapMparseExe(maybess(constexes)mLib)return(mLib,biExes)whereparseLib::[Field]->ParseResult(MaybeBuildInfo)parseLib(bi@((F_inFieldName_):_))|lowercaseinFieldName/="executable"=liftMJust(parseBIbi)parseLib_=returnNothingparseExe::[Field]->ParseResult(String,BuildInfo)parseExe((FlineinFieldNamemName):bi)|lowercaseinFieldName=="executable"=dobis<-parseBIbireturn(mName,bis)|otherwise=syntaxErrorline"expecting 'executable' at top of stanza"parseExe(_:_)=bug"`parseExe' called on a non-field"parseExe[]=syntaxError0"error in parsing buildinfo file. Expected executable stanza"parseBIst=parseFieldsbinfoFieldDescrsstoreXFieldsBIemptyBuildInfost-- ----------------------------------------------------------------------------- Pretty printingwritePackageDescription::FilePath->PackageDescription->IO()writePackageDescriptionfpathpkg=writeUTF8Filefpath(showPackageDescriptionpkg)--TODO: make this use section syntax-- add equivalent for GenericPackageDescriptionshowPackageDescription::PackageDescription->StringshowPackageDescriptionpkg=render$ppPackagepkg$$ppCustomFields(customFieldsPDpkg)$$(caselibrarypkgofNothing->emptyJustlib->ppLibrarylib)$$vcat[space$$ppExecutableexe|exe<-executablespkg]whereppPackage=ppFieldspkgDescrFieldDescrsppLibrary=ppFieldslibFieldDescrsppExecutable=ppFieldsexecutableFieldDescrsppCustomFields::[(String,String)]->DocppCustomFieldsflds=vcat(mapppCustomFieldflds)ppCustomField::(String,String)->DocppCustomField(name,val)=textname<>colon<+>showFreeTextvalwriteHookedBuildInfo::FilePath->HookedBuildInfo->IO()writeHookedBuildInfofpath=writeFileAtomicfpath.showHookedBuildInfoshowHookedBuildInfo::HookedBuildInfo->StringshowHookedBuildInfo(mb_lib_bi,ex_bis)=render$(casemb_lib_biofNothing->emptyJustbi->ppBuildInfobi)$$vcat[space$$text"executable:"<+>textname$$ppBuildInfobi|(name,bi)<-ex_bis]whereppBuildInfobi=ppFieldsbinfoFieldDescrsbi$$ppCustomFields(customFieldsBIbi)-- replace all tabs used as indentation with whitespace, also return where-- tabs were foundfindIndentTabs::String->[(Int,Int)]findIndentTabs=concatMapcheckLine.zip[1..].lineswherecheckLine(lineno,l)=let(indent,_content)=spanisSpaceltabCols=mapfst.filter((=='\t').snd).zip[0..]addLineNo=map(\col->(lineno,col))inaddLineNo(tabColsindent)--test_findIndentTabs = findIndentTabs $ unlines $-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ]bug::String->abugmsg=error$msg++". Consider this a bug."