{-# LANGUAGE OverloadedStrings #-} -- | 'GenericPackageDescription' Field descriptions module Distribution.PackageDescription.Parsec.FieldDescr ( -- * Package description pkgDescrFieldDescrs, storeXFieldsPD, -- * Library libFieldDescrs, storeXFieldsLib, -- * Foreign library foreignLibFieldDescrs, storeXFieldsForeignLib, -- * Executable executableFieldDescrs, storeXFieldsExe, -- * Test suite TestSuiteStanza (..), emptyTestStanza, testSuiteFieldDescrs, storeXFieldsTest, validateTestSuite, -- * Benchmark BenchmarkStanza (..), emptyBenchmarkStanza, benchmarkFieldDescrs, storeXFieldsBenchmark, validateBenchmark, -- * Flag flagFieldDescrs, -- * Source repository sourceRepoFieldDescrs, -- * Setup build info setupBInfoFieldDescrs, ) where import Prelude () import Distribution.Compat.Prelude import qualified Data.ByteString as BS import Data.List (dropWhileEnd) import qualified Distribution.Compat.Parsec as Parsec import Distribution.Compiler (CompilerFlavor (..)) import Distribution.ModuleName (ModuleName) import Distribution.Package import Distribution.Package.TextClass () import Distribution.PackageDescription import Distribution.Types.ForeignLib import Distribution.Parsec.Class import Distribution.Parsec.Types.Common import Distribution.Parsec.Types.FieldDescr import Distribution.Parsec.Types.ParseResult import Distribution.PrettyUtils import Distribution.Simple.Utils (fromUTF8BS) import Distribution.Text (disp, display) import Text.PrettyPrint (vcat) ------------------------------------------------------------------------------- -- common FieldParsers ------------------------------------------------------------------------------- -- | This is /almost/ @'many' 'Distribution.Compat.Parsec.anyChar'@, but it -- -- * trims whitespace from ends of the lines, -- -- * converts lines with only single dot into empty line. -- freeTextFieldParser :: FieldParser String freeTextFieldParser = dropDotLines <$ Parsec.spaces <*> many Parsec.anyChar where -- Example package with dot lines -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal dropDotLines "." = "." dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x dotToEmpty x | trim' x == "." = "" dotToEmpty x = trim x trim' = dropWhileEnd (`elem` (" \t" :: String)) ------------------------------------------------------------------------------- -- PackageDescription ------------------------------------------------------------------------------- -- TODO: other-files isn't used in any cabal file on Hackage. pkgDescrFieldDescrs :: [FieldDescr PackageDescription] pkgDescrFieldDescrs = [ simpleField "name" disp parsec packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) , simpleField "version" disp parsec packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) , simpleField "cabal-version" (either disp disp) (Left <$> parsec <|> Right <$> parsec) specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) , simpleField "build-type" (maybe mempty disp) (Just <$> parsec) buildType (\t pkg -> pkg{buildType=t}) , simpleField "license" disp (parsecMaybeQuoted parsec) license (\l pkg -> pkg{license=l}) , simpleField "license-file" showFilePath parsecFilePath (\pkg -> case licenseFiles pkg of [x] -> x _ -> "") (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [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. , listField "license-files" showFilePath parsecFilePath (\pkg -> case licenseFiles pkg of [_] -> [] xs -> xs) (\ls pkg -> pkg{licenseFiles=ls}) , simpleField "copyright" showFreeText freeTextFieldParser copyright (\val pkg -> pkg{copyright=val}) , simpleField "maintainer" showFreeText freeTextFieldParser maintainer (\val pkg -> pkg{maintainer=val}) , simpleField "stability" showFreeText freeTextFieldParser stability (\val pkg -> pkg{stability=val}) , simpleField "homepage" showFreeText freeTextFieldParser homepage (\val pkg -> pkg{homepage=val}) , simpleField "package-url" showFreeText freeTextFieldParser pkgUrl (\val pkg -> pkg{pkgUrl=val}) , simpleField "bug-reports" showFreeText freeTextFieldParser bugReports (\val pkg -> pkg{bugReports=val}) , simpleField "synopsis" showFreeText freeTextFieldParser synopsis (\val pkg -> pkg{synopsis=val}) , simpleField "description" showFreeText freeTextFieldParser description (\val pkg -> pkg{description=val}) , simpleField "category" showFreeText freeTextFieldParser category (\val pkg -> pkg{category=val}) , simpleField "author" showFreeText freeTextFieldParser author (\val pkg -> pkg{author=val}) , listField "tested-with" showTestedWith parsecTestedWith testedWith (\val pkg -> pkg{testedWith=val}) , listFieldWithSep vcat "data-files" showFilePath parsecFilePath dataFiles (\val pkg -> pkg{dataFiles=val}) , simpleField "data-dir" showFilePath parsecFilePath dataDir (\val pkg -> pkg{dataDir=val}) , listFieldWithSep vcat "extra-source-files" showFilePath parsecFilePath extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) , listFieldWithSep vcat "extra-tmp-files" showFilePath parsecFilePath extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) , listFieldWithSep vcat "extra-doc-files" showFilePath parsecFilePath 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 :: UnknownFieldParser PackageDescription storeXFieldsPD f val pkg | beginsWithX f = Just pkg { customFieldsPD = customFieldsPD pkg ++ [(fromUTF8BS f, trim val)] } storeXFieldsPD _ _ _ = Nothing ------------------------------------------------------------------------------- -- Library ------------------------------------------------------------------------------- libFieldDescrs :: [FieldDescr Library] libFieldDescrs = [ listFieldWithSep vcat "exposed-modules" disp (parsecMaybeQuoted parsec) exposedModules (\mods lib -> lib{exposedModules=mods}) , commaListFieldWithSep vcat "reexported-modules" disp parsec reexportedModules (\mods lib -> lib{reexportedModules=mods}) , listFieldWithSep vcat "signatures" disp (parsecMaybeQuoted parsec) signatures (\mods lib -> lib{signatures=mods}) , boolField "exposed" libExposed (\val lib -> lib{libExposed=val}) ] ++ map biToLib binfoFieldDescrs where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) storeXFieldsLib :: UnknownFieldParser Library storeXFieldsLib f val l@Library { libBuildInfo = bi } | beginsWithX f = Just $ l {libBuildInfo = bi{ customFieldsBI = customFieldsBI bi ++ [(fromUTF8BS f, trim val)]}} storeXFieldsLib _ _ _ = Nothing ------------------------------------------------------------------------------- -- Foreign library ------------------------------------------------------------------------------- foreignLibFieldDescrs :: [FieldDescr ForeignLib] foreignLibFieldDescrs = [ simpleField "type" disp parsec foreignLibType (\x flib -> flib { foreignLibType = x }) , listField "options" disp parsec foreignLibOptions (\x flib -> flib { foreignLibOptions = x }) , listField "mod-def-file" showFilePath parsecFilePath foreignLibModDefFile (\x flib -> flib { foreignLibModDefFile = x }) ] ++ map biToFLib binfoFieldDescrs where biToFLib = liftField foreignLibBuildInfo (\bi flib -> flib{foreignLibBuildInfo=bi}) storeXFieldsForeignLib :: UnknownFieldParser ForeignLib storeXFieldsForeignLib f val l@ForeignLib { foreignLibBuildInfo = bi } | beginsWithX f = Just $ l {foreignLibBuildInfo = bi{ customFieldsBI = customFieldsBI bi ++ [(fromUTF8BS f, trim val)]}} storeXFieldsForeignLib _ _ _ = Nothing ------------------------------------------------------------------------------- -- Executable ------------------------------------------------------------------------------- executableFieldDescrs :: [FieldDescr Executable] executableFieldDescrs = [ -- note ordering: configuration must come first, for -- showPackageDescription. simpleField "executable" disp parsec exeName (\xs exe -> exe{exeName=xs}) , simpleField "main-is" showFilePath parsecFilePath modulePath (\xs exe -> exe{modulePath=xs}) ] ++ map biToExe binfoFieldDescrs where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) storeXFieldsExe :: UnknownFieldParser Executable storeXFieldsExe f val e@Executable { buildInfo = bi } | beginsWithX f = Just $ e {buildInfo = bi{ customFieldsBI = (fromUTF8BS f, trim val) : customFieldsBI bi}} storeXFieldsExe _ _ _ = Nothing ------------------------------------------------------------------------------- -- TestSuite ------------------------------------------------------------------------------- -- | 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 mempty disp) (Just <$> parsec) testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) , simpleField "main-is" (maybe mempty showFilePath) (Just <$> parsecFilePath) testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) , simpleField "test-module" (maybe mempty disp) (Just <$> parsecMaybeQuoted parsec) testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) ] ++ map biToTest binfoFieldDescrs where biToTest = liftField testStanzaBuildInfo (\bi suite -> suite { testStanzaBuildInfo = bi }) storeXFieldsTest :: UnknownFieldParser TestSuiteStanza storeXFieldsTest f val t@TestSuiteStanza { testStanzaBuildInfo = bi } | beginsWithX f = Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (fromUTF8BS f,val):customFieldsBI bi}} storeXFieldsTest _ _ _ = Nothing validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite validateTestSuite pos stanza = case testStanzaTestType stanza of Nothing -> return $ emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } Just tt@(TestTypeUnknown _ _) -> pure emptyTestSuite { testInterface = TestSuiteUnsupported tt , testBuildInfo = testStanzaBuildInfo stanza } Just tt | tt `notElem` knownTestTypes -> pure emptyTestSuite { testInterface = TestSuiteUnsupported tt , testBuildInfo = testStanzaBuildInfo stanza } Just tt@(TestTypeExe ver) -> case testStanzaMainIs stanza of Nothing -> do parseFailure pos (missingField "main-is" tt) pure emptyTestSuite Just file -> do when (isJust (testStanzaTestModule stanza)) $ parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) pure emptyTestSuite { testInterface = TestSuiteExeV10 ver file , testBuildInfo = testStanzaBuildInfo stanza } Just tt@(TestTypeLib ver) -> case testStanzaTestModule stanza of Nothing -> do parseFailure pos (missingField "test-module" tt) pure emptyTestSuite Just module_ -> do when (isJust (testStanzaMainIs stanza)) $ parseWarning pos PWTExtraMainIs (extraField "main-is" tt) pure 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." ------------------------------------------------------------------------------- -- Benchmark ------------------------------------------------------------------------------- -- | 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 mempty disp) (Just <$> parsec) benchmarkStanzaBenchmarkType (\x suite -> suite { benchmarkStanzaBenchmarkType = x }) , simpleField "main-is" (maybe mempty showFilePath) (Just <$> parsecFilePath) benchmarkStanzaMainIs (\x suite -> suite { benchmarkStanzaMainIs = x }) ] ++ map biToBenchmark binfoFieldDescrs where biToBenchmark = liftField benchmarkStanzaBuildInfo (\bi suite -> suite { benchmarkStanzaBuildInfo = bi }) storeXFieldsBenchmark :: UnknownFieldParser BenchmarkStanza storeXFieldsBenchmark f val t@BenchmarkStanza { benchmarkStanzaBuildInfo = bi } | beginsWithX f = Just $ t {benchmarkStanzaBuildInfo = bi{ customFieldsBI = (fromUTF8BS f, trim val):customFieldsBI bi}} storeXFieldsBenchmark _ _ _ = Nothing validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark validateBenchmark pos stanza = case benchmarkStanzaBenchmarkType stanza of Nothing -> pure emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark { benchmarkInterface = BenchmarkUnsupported tt , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark { benchmarkInterface = BenchmarkUnsupported tt , benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza } Just tt@(BenchmarkTypeExe ver) -> case benchmarkStanzaMainIs stanza of Nothing -> do parseFailure pos (missingField "main-is" tt) pure emptyBenchmark Just file -> do when (isJust (benchmarkStanzaBenchmarkModule stanza)) $ parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) pure 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." ------------------------------------------------------------------------------- -- BuildInfo ------------------------------------------------------------------------------- binfoFieldDescrs :: [FieldDescr BuildInfo] binfoFieldDescrs = [ boolField "buildable" buildable (\val binfo -> binfo{buildable=val}) , commaListField "build-tools" disp parsec buildTools (\xs binfo -> binfo{buildTools=xs}) , commaListFieldWithSep vcat "build-depends" disp parsec targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs}) , commaListFieldWithSep vcat "mixins" disp parsec mixins (\xs binfo -> binfo{mixins=xs}) , spaceListField "cpp-options" showToken parsecToken' cppOptions (\val binfo -> binfo{cppOptions=val}) , spaceListField "cc-options" showToken parsecToken' ccOptions (\val binfo -> binfo{ccOptions=val}) , spaceListField "ld-options" showToken parsecToken' ldOptions (\val binfo -> binfo{ldOptions=val}) , commaListField "pkgconfig-depends" disp parsec pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) , listField "frameworks" showToken parsecToken frameworks (\val binfo -> binfo{frameworks=val}) , listField "extra-framework-dirs" showToken parsecFilePath extraFrameworkDirs (\val binfo -> binfo{extraFrameworkDirs=val}) , listFieldWithSep vcat "c-sources" showFilePath parsecFilePath cSources (\paths binfo -> binfo{cSources=paths}) , listFieldWithSep vcat "js-sources" showFilePath parsecFilePath jsSources (\paths binfo -> binfo{jsSources=paths}) , simpleField "default-language" (maybe mempty disp) (Parsec.optionMaybe $ parsecMaybeQuoted parsec) defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) , listField "other-languages" disp (parsecMaybeQuoted parsec) otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) , listField "default-extensions" disp (parsecMaybeQuoted parsec) defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) , listField "other-extensions" disp (parsecMaybeQuoted parsec) otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) , listField "extensions" -- TODO: this is deprecated field, isn't it? disp (parsecMaybeQuoted parsec) oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) , listFieldWithSep vcat "extra-libraries" showToken parsecToken extraLibs (\xs binfo -> binfo{extraLibs=xs}) , listFieldWithSep vcat "extra-ghci-libraries" showToken parsecToken extraGHCiLibs (\xs binfo -> binfo{extraGHCiLibs=xs}) , listField "extra-lib-dirs" showFilePath parsecFilePath extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) , listFieldWithSep vcat "includes" showFilePath parsecFilePath includes (\paths binfo -> binfo{includes=paths}) , listFieldWithSep vcat "install-includes" showFilePath parsecFilePath installIncludes (\paths binfo -> binfo{installIncludes=paths}) , listField "include-dirs" showFilePath parsecFilePath includeDirs (\paths binfo -> binfo{includeDirs=paths}) , listField "hs-source-dirs" showFilePath parsecFilePath hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) , deprecatedField "hs-source-dirs" $ listField "hs-source-dir" showFilePath parsecFilePath (const []) (\paths binfo -> binfo{hsSourceDirs=paths}) , listFieldWithSep vcat "other-modules" disp (parsecMaybeQuoted parsec) otherModules (\val binfo -> binfo{otherModules=val}) , listFieldWithSep vcat "autogen-modules" disp (parsecMaybeQuoted parsec) autogenModules (\val binfo -> binfo{autogenModules=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. -- -- TODO: deprecate? , optsField "hugs-options" Hugs options (const id) , optsField "nhc98-options" NHC options (const id) ] {- storeXFieldsBI :: UnknownFieldParser BuildInfo --storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi } storeXFieldsBI _ _ = Nothing -} ------------------------------------------------------------------------------- -- Flag ------------------------------------------------------------------------------- flagFieldDescrs :: [FieldDescr Flag] flagFieldDescrs = [ simpleField "description" showFreeText freeTextFieldParser flagDescription (\val fl -> fl{ flagDescription = val }) , boolField "default" flagDefault (\val fl -> fl{ flagDefault = val }) , boolField "manual" flagManual (\val fl -> fl{ flagManual = val }) ] ------------------------------------------------------------------------------- -- SourceRepo ------------------------------------------------------------------------------- sourceRepoFieldDescrs :: [FieldDescr SourceRepo] sourceRepoFieldDescrs = [ simpleField "type" (maybe mempty disp) (Just <$> parsec) repoType (\val repo -> repo { repoType = val }) , simpleField "location" (maybe mempty showFreeText) (Just <$> freeTextFieldParser) repoLocation (\val repo -> repo { repoLocation = val }) , simpleField "module" (maybe mempty showToken) (Just <$> parsecToken) repoModule (\val repo -> repo { repoModule = val }) , simpleField "branch" (maybe mempty showToken) (Just <$> parsecToken) repoBranch (\val repo -> repo { repoBranch = val }) , simpleField "tag" (maybe mempty showToken) (Just <$> parsecToken) repoTag (\val repo -> repo { repoTag = val }) , simpleField "subdir" (maybe mempty showFilePath) (Just <$> parsecFilePath) repoSubdir (\val repo -> repo { repoSubdir = val }) ] ------------------------------------------------------------------------------- -- SetupBuildInfo ------------------------------------------------------------------------------- setupBInfoFieldDescrs :: [FieldDescr SetupBuildInfo] setupBInfoFieldDescrs = [ commaListFieldWithSep vcat "setup-depends" disp parsec setupDepends (\xs binfo -> binfo{setupDepends=xs}) ] ------------------------------------------------------------------------------- -- Utilities ------------------------------------------------------------------------------- -- | Predicate to test field names beginning with "x-" beginsWithX :: FieldName -> Bool beginsWithX bs = BS.take 2 bs == "x-" -- | Mark the field as deprecated. deprecatedField :: FieldName -- ^ alternative field -> FieldDescr a -> FieldDescr a deprecatedField newFieldName fd = FieldDescr { fieldName = oldFieldName , fieldPretty = const mempty -- we don't print deprecated field , fieldParser = \x -> do parsecWarning PWTDeprecatedField $ "The field " <> show oldFieldName <> " is deprecated, please use " <> show newFieldName fieldParser fd x } where oldFieldName = fieldName fd -- Used to trim x-fields trim :: String -> String trim = dropWhile isSpace . dropWhileEnd isSpace