----------------------------------------------------------------------------- -- | -- Module : Distribution.PackageDescription -- Copyright : Isaac Jones 2003-2005 -- -- Maintainer : Isaac Jones -- Stability : alpha -- Portability : portable -- -- Package description and parsing. {- 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. -} module Distribution.PackageDescription ( -- * Package descriptions PackageDescription(..), GenericPackageDescription(..), emptyPackageDescription, readPackageDescription, writePackageDescription, parsePackageDescription, showPackageDescription, BuildType(..), knownBuildTypes, -- ** Libraries Library(..), emptyLibrary, withLib, hasLibs, libModules, -- ** Executables Executable(..), emptyExecutable, withExe, hasExes, exeModules, -- ** Parsing FieldDescr(..), LineNo, -- * Build information BuildInfo(..), emptyBuildInfo, allBuildInfo, hcOptions, -- ** Supplementary build information HookedBuildInfo, emptyHookedBuildInfo, updatePackageDescription, -- * package configuration Flag(..), FlagName(..), FlagAssignment, CondTree(..), ConfVar(..), Condition(..), freeVars, -- ** Supplementary build information readHookedBuildInfo, parseHookedBuildInfo, writeHookedBuildInfo, showHookedBuildInfo, -- * Deprecated compat stuff ParseResult(..), setupMessage, cabalVersion, ) where import Data.Maybe (listToMaybe) import Data.List (nub, unfoldr, partition, (\\)) import Data.Monoid (Monoid(mempty, mappend)) import Text.PrettyPrint.HughesPJ as Disp import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ((+++)) import qualified Data.Char as Char (isAlphaNum, isSpace) import Control.Monad (liftM, foldM, when, unless) import System.Directory (doesFileExist) import Distribution.Package ( PackageIdentifier(..), Dependency, Package(..) , parsePackageName, packageName, packageVersion ) import Distribution.Version ( Version(Version), VersionRange(AnyVersion) , isAnyVersion, withinRange ) import Distribution.License (License(AllRightsReserved)) import Distribution.Compiler (CompilerFlavor(..)) import Distribution.System (OS, Arch) import Distribution.ParseUtils import Distribution.Text ( Text(..), display, simpleParse ) import Distribution.Simple.Utils ( currentDir, notice, die, dieWithLocation, warn, intercalate , lowercase, cabalVersion, readUTF8File, writeUTF8File ) import Language.Haskell.Extension (Extension) import Distribution.Verbosity (Verbosity) -- ----------------------------------------------------------------------------- -- The PackageDescription type -- | This data type is the internal representation of the file @pkg.cabal@. -- It contains two kinds of information about the package: information -- which is needed for all packages, such as the package name and version, and -- information which is needed for the simple build system only, such as -- the compiler options and library name. -- data PackageDescription = PackageDescription { -- the following are required by all packages: package :: PackageIdentifier, license :: License, licenseFile :: FilePath, copyright :: String, maintainer :: String, author :: String, stability :: String, testedWith :: [(CompilerFlavor,VersionRange)], homepage :: String, pkgUrl :: String, synopsis :: String, -- ^A one-line summary of this package description :: String, -- ^A more verbose description of this package category :: String, customFieldsPD :: [(String,String)], -- ^Custom fields starting -- with x-, stored in a -- simple assoc-list. buildDepends :: [Dependency], descCabalVersion :: VersionRange, -- ^If this package depends on a specific version of Cabal, give that here. buildType :: Maybe BuildType, -- components library :: Maybe Library, executables :: [Executable], dataFiles :: [FilePath], dataDir :: FilePath, extraSrcFiles :: [FilePath], extraTmpFiles :: [FilePath] } deriving (Show, Read, Eq) instance Package PackageDescription where packageId = package emptyPackageDescription :: PackageDescription emptyPackageDescription = PackageDescription {package = PackageIdentifier "" (Version [] []), license = AllRightsReserved, licenseFile = "", descCabalVersion = AnyVersion, buildType = Nothing, copyright = "", maintainer = "", author = "", stability = "", testedWith = [], buildDepends = [], homepage = "", pkgUrl = "", synopsis = "", description = "", category = "", customFieldsPD = [], library = Nothing, executables = [], dataFiles = [], dataDir = "", extraSrcFiles = [], extraTmpFiles = [] } -- | The type of build system used by this package. data BuildType = Simple -- ^ calls @Distribution.Simple.defaultMain@ | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, -- which invokes @configure@ to generate additional build -- information used by later phases. | Make -- ^ calls @Distribution.Make.defaultMain@ | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) | UnknownBuildType String -- ^ a package that uses an unknown build type cannot actually -- be built. Doing it this way rather than just giving a -- parse error means we get better error messages and allows -- you to inspect the rest of the package description. deriving (Show, Read, Eq) knownBuildTypes :: [BuildType] knownBuildTypes = [Simple, Configure, Make, Custom] instance Text BuildType where disp (UnknownBuildType other) = Disp.text other disp other = Disp.text (show other) parse = do name <- Parse.munch1 Char.isAlphaNum return $ case name of "Simple" -> Simple "Configure" -> Configure "Custom" -> Custom "Make" -> Make _ -> UnknownBuildType name -- --------------------------------------------------------------------------- -- The Library type data Library = Library { exposedModules :: [String], libBuildInfo :: BuildInfo } deriving (Show, Eq, Read) instance Monoid Library where mempty = nullLibrary mappend = unionLibrary emptyLibrary :: Library emptyLibrary = Library [] emptyBuildInfo nullLibrary :: Library nullLibrary = Library [] nullBuildInfo -- |does this package have any libraries? hasLibs :: PackageDescription -> Bool hasLibs p = maybe False (buildable . libBuildInfo) (library p) -- |'Maybe' version of 'hasLibs' maybeHasLibs :: PackageDescription -> Maybe Library maybeHasLibs p = library p >>= \lib -> if buildable (libBuildInfo lib) then Just lib else Nothing -- |If the package description has a library section, call the given -- function with the library build info as argument. withLib :: PackageDescription -> a -> (Library -> IO a) -> IO a withLib pkg_descr a f = maybe (return a) f (maybeHasLibs pkg_descr) -- |Get all the module names from the libraries in this package libModules :: PackageDescription -> [String] libModules PackageDescription{library=lib} = maybe [] exposedModules lib ++ maybe [] (otherModules . libBuildInfo) lib unionLibrary :: Library -> Library -> Library unionLibrary l1 l2 = l1 { exposedModules = combine exposedModules , libBuildInfo = unionBuildInfo (libBuildInfo l1) (libBuildInfo l2) } where combine f = f l1 ++ f l2 -- --------------------------------------------------------------------------- -- The Executable type data Executable = Executable { exeName :: String, modulePath :: FilePath, buildInfo :: BuildInfo } deriving (Show, Read, Eq) instance Monoid Executable where mempty = nullExecutable mappend = unionExecutable emptyExecutable :: Executable emptyExecutable = Executable { exeName = "", modulePath = "", buildInfo = emptyBuildInfo } nullExecutable :: Executable nullExecutable = emptyExecutable { buildInfo = nullBuildInfo } -- |does this package have any executables? hasExes :: PackageDescription -> Bool hasExes p = any (buildable . buildInfo) (executables p) -- | Perform the action on each buildable 'Executable' in the package -- description. withExe :: PackageDescription -> (Executable -> IO a) -> IO () withExe pkg_descr f = sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] -- |Get all the module names from the exes in this package exeModules :: PackageDescription -> [String] exeModules PackageDescription{executables=execs} = concatMap (otherModules . buildInfo) execs unionExecutable :: Executable -> Executable -> Executable unionExecutable e1 e2 = e1 { exeName = combine exeName , modulePath = combine modulePath , buildInfo = unionBuildInfo (buildInfo e1) (buildInfo e2) } where combine f = case (f e1, f e2) of ("","") -> "" ("", x) -> x (x, "") -> x (x, y) -> error $ "Ambiguous values for executable field: '" ++ x ++ "' and '" ++ y ++ "'" -- --------------------------------------------------------------------------- -- The BuildInfo type -- Consider refactoring into executable and library versions. data BuildInfo = BuildInfo { buildable :: Bool, -- ^ component is buildable here buildTools :: [Dependency], -- ^ tools needed to build this bit cppOptions :: [String], -- ^ options for pre-processing Haskell code ccOptions :: [String], -- ^ options for C compiler ldOptions :: [String], -- ^ options for linker pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used frameworks :: [String], -- ^support frameworks for Mac OS X cSources :: [FilePath], hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy otherModules :: [String], -- ^ non-exposed or non-main modules extensions :: [Extension], extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package extraLibDirs :: [String], includeDirs :: [FilePath], -- ^directories to find .h files includes :: [FilePath], -- ^ The .h files to be found in includeDirs installIncludes :: [FilePath], -- ^ .h files to install with the package options :: [(CompilerFlavor,[String])], ghcProfOptions :: [String], ghcSharedOptions :: [String], customFieldsBI :: [(String,String)] -- ^Custom fields starting -- with x-, stored in a -- simple assoc-list. } deriving (Show,Read,Eq) instance Monoid BuildInfo where mempty = nullBuildInfo mappend = unionBuildInfo nullBuildInfo :: BuildInfo nullBuildInfo = BuildInfo { buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [], otherModules = [], extensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [] } emptyBuildInfo :: BuildInfo emptyBuildInfo = nullBuildInfo { hsSourceDirs = [currentDir] } -- | The 'BuildInfo' for the library (if there is one and it's buildable) and -- all the buildable executables. Useful for gathering dependencies. allBuildInfo :: PackageDescription -> [BuildInfo] allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] , let bi = libBuildInfo lib , buildable bi ] ++ [ bi | exe <- executables pkg_descr , let bi = buildInfo exe , buildable bi ] type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) emptyHookedBuildInfo :: HookedBuildInfo emptyHookedBuildInfo = (Nothing, []) -- |Select options for a particular Haskell compiler. hcOptions :: CompilerFlavor -> BuildInfo -> [String] hcOptions hc bi = [ opt | (hc',opts) <- options bi , hc' == hc , opt <- opts ] -- ------------------------------------------------------------ -- * Utils -- ------------------------------------------------------------ updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription updatePackageDescription (mb_lib_bi, exe_bi) p = p{ executables = updateExecutables exe_bi (executables p) , library = updateLibrary mb_lib_bi (library p) } where updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = unionBuildInfo bi (libBuildInfo lib)}) updateLibrary Nothing mb_lib = mb_lib --the lib only exists in the buildinfo file. FIX: Is this --wrong? If there aren't any exposedModules, then the library --won't build anyway. add to sanity checker? updateLibrary (Just bi) Nothing = Just emptyLibrary{libBuildInfo=bi} updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] -> [Executable] -- ^list of executables to update -> [Executable] -- ^list with exeNames updated updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) -> [Executable] -- ^list of executables to update -> [Executable] -- ^libst with exeName updated updateExecutable _ [] = [] updateExecutable exe_bi'@(name,bi) (exe:exes) | exeName exe == name = exe{buildInfo = unionBuildInfo bi (buildInfo exe)} : exes | otherwise = exe : updateExecutable exe_bi' exes unionBuildInfo :: BuildInfo -> BuildInfo -> BuildInfo unionBuildInfo b1 b2 = BuildInfo { buildable = buildable b1 && buildable b2, buildTools = combineNub buildTools, cppOptions = combine cppOptions, ccOptions = combine ccOptions, ldOptions = combine ldOptions, pkgconfigDepends = combineNub pkgconfigDepends, frameworks = combineNub frameworks, cSources = combineNub cSources, hsSourceDirs = combineNub hsSourceDirs, otherModules = combineNub otherModules, extensions = combineNub extensions, extraLibs = combine extraLibs, extraLibDirs = combineNub extraLibDirs, includeDirs = combineNub includeDirs, includes = combineNub includes, installIncludes = combineNub installIncludes, options = combine options, ghcProfOptions = combine ghcProfOptions, ghcSharedOptions = combine ghcSharedOptions, customFieldsBI = combine customFieldsBI } where combine f = f b1 ++ f b2 combineNub f = nub (combine f) -- --------------------------------------------------------------------------- -- The GenericPackageDescription type data GenericPackageDescription = GenericPackageDescription { packageDescription :: PackageDescription, genPackageFlags :: [Flag], condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] } deriving (Show) instance Package GenericPackageDescription where packageId = packageId . packageDescription {- -- XXX: I think we really want a PPrint or Pretty or ShowPretty class. instance Show GenericPackageDescription where show (GenericPackageDescription pkg flgs mlib exes) = showPackageDescription pkg ++ "\n" ++ (render $ vcat $ map ppFlag flgs) ++ "\n" ++ render (maybe empty (\l -> showStanza "Library" (ppCondTree l showDeps)) mlib) ++ "\n" ++ (render $ vcat $ map (\(n,ct) -> showStanza ("Executable " ++ n) (ppCondTree ct showDeps)) exes) where ppFlag (MkFlag name desc dflt) = showStanza ("Flag " ++ name) ((if (null desc) then empty else text ("Description: " ++ desc)) $+$ text ("Default: " ++ show dflt)) showDeps = fsep . punctuate comma . map showDependency showStanza h b = text h <+> lbrace $+$ nest 2 b $+$ rbrace -} -- | A flag can represent a feature to be included, or a way of linking -- a target against its dependencies, or in fact whatever you can think of. data Flag = MkFlag { flagName :: FlagName , flagDescription :: String , flagDefault :: Bool } deriving Show -- | A 'FlagName' is the name of a user-defined configuration flag newtype FlagName = FlagName String deriving (Eq, Ord, Show, Read) -- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to -- 'Bool' flag values. It represents the flags chosen by the user or -- discovered during configuration. For example @--flags=foo --flags=-bar@ -- becomes @[("foo", True), ("bar", False)]@ -- type FlagAssignment = [(FlagName, Bool)] -- | A @ConfVar@ represents the variable type used. data ConfVar = OS OS | Arch Arch | Flag FlagName | Impl CompilerFlavor VersionRange deriving (Eq, Show) --instance Text ConfVar where -- disp (OS os) = "os(" ++ display os ++ ")" -- disp (Arch arch) = "arch(" ++ display arch ++ ")" -- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")" -- disp (Impl c v) = "impl(" ++ display c -- ++ " " ++ display v ++ ")" -- | A boolean expression parameterized over the variable type used. data Condition c = Var c | Lit Bool | CNot (Condition c) | COr (Condition c) (Condition c) | CAnd (Condition c) (Condition c) deriving Show --instance Text c => Text (Condition c) where -- disp (Var x) = text (show x) -- disp (Lit b) = text (show b) -- disp (CNot c) = char '!' <> parens (ppCond c) -- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2] -- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2] data CondTree v c a = CondNode { condTreeData :: a , condTreeConstraints :: c , condTreeComponents :: [( Condition v , CondTree v c a , Maybe (CondTree v c a))] } deriving Show --instance (Text v, Text c) => Text (CondTree v c a) where -- disp (CondNode _dat cs ifs) = -- (text "build-depends: " <+> -- disp cs) -- $+$ -- (vcat $ map ppIf ifs) -- where -- ppIf (c,thenTree,mElseTree) = -- ((text "if" <+> ppCond c <> colon) $$ -- nest 2 (ppCondTree thenTree disp)) -- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp)) -- mElseTree) freeVars :: CondTree ConfVar c a -> [FlagName] freeVars t = [ f | Flag f <- freeVars' t ] where freeVars' (CondNode _ _ ifs) = concatMap compfv ifs compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct condfv c = case c of Var v -> [v] Lit _ -> [] CNot c' -> condfv c' COr c1 c2 -> condfv c1 ++ condfv c2 CAnd c1 c2 -> condfv c1 ++ condfv c2 -- --------------------------------------------------------------------------- -- Deprecated compat stuff {-# DEPRECATED setupMessage "it's exported from the Utils module now" #-} setupMessage :: Verbosity -> String -> PackageDescription -> IO () setupMessage verbosity msg pkg_descr = notice verbosity (msg ++ ' ': display (packageId pkg_descr) ++ "...") -- ----------------------------------------------------------------------------- -- The PackageDescription type pkgDescrFieldDescrs :: [FieldDescr PackageDescription] pkgDescrFieldDescrs = [ simpleField "name" text parsePackageName 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" disp parse descCabalVersion (\v pkg -> pkg{descCabalVersion=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 licenseFile (\l pkg -> pkg{licenseFile=l}) , simpleField "copyright" showFreeText (Parse.munch (const True)) copyright (\val pkg -> pkg{copyright=val}) , simpleField "maintainer" showFreeText (Parse.munch (const True)) maintainer (\val pkg -> pkg{maintainer=val}) , commaListField "build-depends" disp parse buildDepends (\xs pkg -> pkg{buildDepends=xs}) , simpleField "stability" showFreeText (Parse.munch (const True)) stability (\val pkg -> pkg{stability=val}) , simpleField "homepage" showFreeText (Parse.munch (const True)) homepage (\val pkg -> pkg{homepage=val}) , simpleField "package-url" showFreeText (Parse.munch (const True)) pkgUrl (\val pkg -> pkg{pkgUrl=val}) , simpleField "synopsis" showFreeText (Parse.munch (const True)) synopsis (\val pkg -> pkg{synopsis=val}) , simpleField "description" showFreeText (Parse.munch (const True)) description (\val pkg -> pkg{description=val}) , simpleField "category" showFreeText (Parse.munch (const True)) category (\val pkg -> pkg{category=val}) , simpleField "author" showFreeText (Parse.munch (const True)) author (\val pkg -> pkg{author=val}) , listField "tested-with" showTestedWith parseTestedWithQ testedWith (\val pkg -> pkg{testedWith=val}) , listField "data-files" showFilePath parseFilePathQ dataFiles (\val pkg -> pkg{dataFiles=val}) , simpleField "data-dir" showFilePath parseFilePathQ dataDir (\val pkg -> pkg{dataDir=val}) , listField "extra-source-files" showFilePath parseFilePathQ extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) , listField "extra-tmp-files" showFilePath parseFilePathQ extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) ] -- | Store any fields beginning with "x-" in the customFields field of -- a PackageDescription. All other fields will generate a warning. storeXFieldsPD :: UnrecFieldParser PackageDescription storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = (f,val):(customFieldsPD pkg) } storeXFieldsPD _ _ = Nothing -- --------------------------------------------------------------------------- -- The Library type libFieldDescrs :: [FieldDescr Library] libFieldDescrs = map biToLib binfoFieldDescrs ++ [ listField "exposed-modules" text parseModuleNameQ exposedModules (\mods lib -> lib{exposedModules=mods}) ] 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 = (f,val):(customFieldsBI bi) }} storeXFieldsLib _ _ = Nothing -- --------------------------------------------------------------------------- -- The Executable type executableFieldDescrs :: [FieldDescr Executable] executableFieldDescrs = [ -- note ordering: configuration must come first, for -- showPackageDescription. simpleField "executable" showToken parseTokenQ exeName (\xs exe -> exe{exeName=xs}) , simpleField "main-is" showFilePath parseFilePathQ modulePath (\xs exe -> exe{modulePath=xs}) ] ++ map biToExe binfoFieldDescrs where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) storeXFieldsExe :: UnrecFieldParser Executable storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} storeXFieldsExe _ _ = Nothing -- --------------------------------------------------------------------------- -- The BuildInfo type binfoFieldDescrs :: [FieldDescr BuildInfo] binfoFieldDescrs = [ boolField "buildable" buildable (\val binfo -> binfo{buildable=val}) , commaListField "build-tools" disp parseBuildTool buildTools (\xs binfo -> binfo{buildTools=xs}) , listField "cpp-options" showToken parseTokenQ cppOptions (\val binfo -> binfo{cppOptions=val}) , listField "cc-options" showToken parseTokenQ ccOptions (\val binfo -> binfo{ccOptions=val}) , listField "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}) , listField "c-sources" showFilePath parseFilePathQ cSources (\paths binfo -> binfo{cSources=paths}) , listField "extensions" disp parseExtensionQ extensions (\exts binfo -> binfo{extensions=exts}) , listField "extra-libraries" showToken parseTokenQ extraLibs (\xs binfo -> binfo{extraLibs=xs}) , listField "extra-lib-dirs" showFilePath parseFilePathQ extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) , listField "includes" showFilePath parseFilePathQ includes (\paths binfo -> binfo{includes=paths}) , listField "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}) , listField "other-modules" text parseModuleNameQ otherModules (\val binfo -> binfo{otherModules=val}) , listField "ghc-prof-options" text parseTokenQ ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val}) , listField "ghc-shared-options" text parseTokenQ ghcProfOptions (\val binfo -> binfo{ghcSharedOptions=val}) , optsField "ghc-options" GHC options (\path binfo -> binfo{options=path}) , optsField "hugs-options" Hugs options (\path binfo -> binfo{options=path}) , optsField "nhc98-options" NHC options (\path binfo -> binfo{options=path}) , optsField "jhc-options" JHC options (\path binfo -> binfo{options=path}) ] storeXFieldsBI :: UnrecFieldParser BuildInfo storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) } storeXFieldsBI _ _ = Nothing ------------------------------------------------------------------------------ flagFieldDescrs :: [FieldDescr Flag] flagFieldDescrs = [ simpleField "description" showFreeText (Parse.munch (const True)) flagDescription (\val fl -> fl{ flagDescription = val }) , boolField "default" flagDefault (\val fl -> fl{ flagDefault = val }) ] -- --------------------------------------------------------------- -- Parsing -- | Given a parser and a filename, return the parse of the file, -- after checking if the file exists. readAndParseFile :: (FilePath -> IO String) -> (String -> ParseResult a) -> Verbosity -> FilePath -> IO a readAndParseFile readFile' parser verbosity fpath = do exists <- doesFileExist fpath when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") str <- readFile' fpath 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 readFile parseHookedBuildInfo -- |Parse the given package file. readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription readPackageDescription = readAndParseFile readUTF8File 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 fs = mapM walk fs where walk fld@(F _ _ _) = f fld walk (IfBlock l c fs1 fs2) = do fs1' <- mapM walk fs1 fs2' <- mapM walk fs2 return (IfBlock l c fs1' fs2') walk (Section ln n l fs1) = do fs1' <- mapM walk fs1 return (Section ln n l fs1') -- prop_isMapM fs = mapSimpleFields return fs == return fs -- names of fields that represents dependencies, thus consrca constraintFieldNames :: [String] constraintFieldNames = ["build-depends"] -- Possible refactoring would be to have modifiers be explicit about what -- they add and define an accessor that specifies what the dependencies -- are. This way we would completely reuse the parsing knowledge from the -- field descriptor. parseConstraint :: Field -> ParseResult [Dependency] parseConstraint (F l n v) | n == "build-depends" = runP l n (parseCommaList parse) v parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")" {- headerFieldNames :: [String] headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) . map fieldName $ pkgDescrFieldDescrs -} libFieldNames :: [String] libFieldNames = map fieldName libFieldDescrs ++ buildInfoNames ++ constraintFieldNames -- exeFieldNames :: [String] -- exeFieldNames = map fieldName executableFieldDescrs -- ++ buildInfoNames buildInfoNames :: [String] buildInfoNames = map fieldName binfoFieldDescrs ++ map fst deprecatedFieldsBuildInfo -- A minimal implementation of the StateT monad transformer to avoid depending -- on the 'mtl' package. newtype StT s m a = StT { runStT :: s -> m (a,s) } instance 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 = runStT st s >>= return . fst -- Our monad for parsing a list/tree of fields. -- -- The state represents the remaining fields to be processed. type PM a = StT [Field] ParseResult a -- return look-ahead field or nothing if we're at the end of the file peekField :: PM (Maybe Field) peekField = 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 = modify tail -- | Parses the given file into a 'GenericPackageDescription'. -- -- In Cabal 1.2 the syntax for package descriptions was changed to a format -- with sections and possibly indented property descriptions. parsePackageDescription :: String -> ParseResult GenericPackageDescription parsePackageDescription file = do let tabs = findIndentTabs file fields0 <- readFields file `catchParseError` \err -> case err of -- In case of a TabsError report them all at once. TabsError tabLineNo -> reportTabsError -- but only report the ones including and following -- the one that caused the actual error [ t | t@(lineNo',_) <- tabs , lineNo' >= tabLineNo ] _ -> parseFail err let cabalVersionNeeded = head $ [ versionRange | Just versionRange <- [ simpleParse v | F _ "cabal-version" v <- fields0 ] ] ++ [AnyVersion] handleFutureVersionParseFailure cabalVersionNeeded $ do let sf = sectionizeFields fields0 fields <- mapSimpleFields deprecField sf flip evalStT fields $ do hfs <- getHeader [] pkg <- lift $ parseFields pkgDescrFieldDescrs storeXFieldsPD emptyPackageDescription hfs (flags, mlib, exes) <- getBody warnIfRest when (not (oldSyntax fields0)) $ maybeWarnCabalVersion pkg checkForUndefinedFlags flags mlib exes return (GenericPackageDescription pkg flags mlib exes) where oldSyntax flds = all isSimpleField flds 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 pkg = when (packageName pkg /= "Cabal" -- supress warning for Cabal && isAnyVersion (descCabalVersion pkg)) $ lift $ warning $ "A package using section syntax should require\n" ++ "\"Cabal-Version: >= 1.2\" or equivalent." handleFutureVersionParseFailure cabalVersionNeeded parseBody = (unless versionOk (warning message) >> parseBody) `catchParseError` \parseError -> case parseError of TabsError _ -> parseFail parseError _ | versionOk -> parseFail parseError | otherwise -> fail message where versionOk = cabalVersion `withinRange` cabalVersionNeeded message = "This package requires Cabal version: " ++ display cabalVersionNeeded -- "Sectionize" an old-style Cabal file. A sectionized file has: -- -- * all global fields at the beginning, followed by -- * all flag declarations, followed by -- * an optional library section, and -- * an arbitrary number of executable sections. -- -- 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] sectionizeFields fs | oldSyntax fs = let -- "build-depends" is a local field now. To be backwards -- compatible, we still allow it as a global field in old-style -- package description files and translate it to a local field by -- adding it to every non-empty section (hdr0, exes0) = break ((=="executable") . fName) fs (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 (deps, libfs) = partition ((== "build-depends") . fName) libfs0 exes = unfoldr toExe exes0 toExe [] = Nothing toExe (F l e n : r) | e == "executable" = let (efs, r') = break ((=="executable") . fName) r in Just (Section l "executable" n (deps ++ efs), r') toExe _ = bug "unexpeced input to 'toExe'" in hdr ++ (if null libfs then [] else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) ++ exes | otherwise = fs isSimpleField (F _ _ _) = True isSimpleField _ = False -- warn if there's something at the end of the file warnIfRest :: PM () warnIfRest = do s <- get case s of [] -> return () _ -> lift $ warning "Ignoring trailing declarations." -- add line no. -- all simple fields at the beginning of the file are (considered) header -- fields getHeader :: [Field] -> PM [Field] getHeader acc = peekField >>= \mf -> case mf of Just f@(F _ _ _) -> skipField >> getHeader (f:acc) _ -> return (reverse acc) -- -- body ::= flag* { library | executable }+ -- at most one lib -- -- The body consists of an optional sequence of flag declarations and after -- that an arbitrary number of executables and an optional library. The -- order of the latter doesn't play a role. getBody :: PM ([Flag] ,Maybe (CondTree ConfVar [Dependency] Library) ,[(String, CondTree ConfVar [Dependency] Executable)]) getBody = do mf <- peekField case mf of Just (Section _ sn _label _fields) | sn == "flag" -> do -- don't skipField here. it's simpler to let getFlags do it -- itself flags <- getFlags [] (lib, exes) <- getLibOrExe return (flags, lib, exes) | otherwise -> do (lib,exes) <- getLibOrExe return ([], lib, exes) Nothing -> do lift $ warning "No library or executable specified" return ([], Nothing, []) Just f -> lift $ syntaxError (lineNo f) $ "Construct not supported at this position: " ++ show f -- -- flags ::= "flag:" name { flag_prop } -- getFlags :: [Flag] -> StT [Field] ParseResult [Flag] getFlags acc = peekField >>= \mf -> case mf of Just (Section _ sn sl fs) | sn == "flag" -> do fl <- lift $ parseFields flagFieldDescrs warnUnrec (MkFlag (FlagName (lowercase sl)) "" True) fs skipField >> getFlags (fl : acc) _ -> return (reverse acc) getLibOrExe :: PM (Maybe (CondTree ConfVar [Dependency] Library) ,[(String, CondTree ConfVar [Dependency] Executable)]) getLibOrExe = peekField >>= \mf -> case mf of Just (Section n sn sl fs) | sn == "executable" -> do when (null sl) $ lift $ syntaxError n "'executable' needs one argument (the executable's name)" exename <- lift $ runP n "executable" parseTokenQ sl flds <- collectFields parseExeFields fs skipField (lib, exes) <- getLibOrExe return (lib, exes ++ [(exename, flds)]) | sn == "library" -> do when (not (null sl)) $ lift $ syntaxError n "'library' expects no argument" flds <- collectFields parseLibFields fs skipField (lib, exes) <- getLibOrExe return (maybe (Just flds) (const (error "Multiple libraries specified")) lib , exes) | otherwise -> do lift $ warning $ "Unknown section type: " ++ sn ++ " ignoring..." return (Nothing, []) -- yep Just x -> lift $ syntaxError (lineNo x) $ "Section expected." Nothing -> return (Nothing, []) -- extracts all fields in a block, possibly add dependencies to the -- guard condition collectFields :: ([Field] -> PM a) -> [Field] -> PM (CondTree ConfVar [Dependency] a) collectFields parser allflds = do a <- parser dataFlds deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds ifs <- mapM processIfs condFlds return (CondNode a deps ifs) where (depFlds, dataFlds) = partition isConstraint simplFlds simplFlds = [ F l n v | F l n v <- allflds ] condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ] 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 _ = bug "processIfs called with wrong field type" parseLibFields :: [Field] -> StT s ParseResult Library parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary parseExeFields :: [Field] -> StT s ParseResult Executable parseExeFields = lift . parseFields executableFieldDescrs storeXFieldsExe emptyExecutable checkForUndefinedFlags :: [Flag] -> Maybe (CondTree ConfVar [Dependency] Library) -> [(String, CondTree ConfVar [Dependency] Executable)] -> PM () checkForUndefinedFlags flags mlib exes = do let definedFlags = map flagName flags maybe (return ()) (checkCondTreeFlags definedFlags) mlib mapM_ (checkCondTreeFlags definedFlags . snd) exes checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () checkCondTreeFlags definedFlags ct = do let fv = nub $ freeVars ct when (not . all (`elem` definedFlags) $ fv) $ fail $ "These flags are used without having been defined: " ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] -- | Parse a list of fields, given a list of field descriptions, -- a structure to accumulate the parsed fields, and a function -- that can decide what to do with fields which don't match any -- of the field descriptions. parseFields :: [FieldDescr a] -- ^ list of parseable fields -> UnrecFieldParser a -- ^ possibly do something with -- unrecognized fields -> a -- ^ accumulator -> [Field] -- ^ fields to be parsed -> ParseResult a parseFields descrs unrec ini fields = do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields when (not (null unknowns)) $ do warning $ render $ text "Unknown fields:" <+> commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") (reverse unknowns)) $+$ text "Fields allowed in this section:" $$ nest 4 (commaSep $ map fieldName descrs) return a where commaSep = fsep . punctuate comma . map text parseField :: [FieldDescr a] -- ^ list of parseable fields -> UnrecFieldParser a -- ^ possibly do something with -- unrecognized fields -> (a,[(Int,String)]) -- ^ accumulated result and warnings -> Field -- ^ the field to be parsed -> ParseResult (a, [(Int,String)]) parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val) | name == f = parser line val a >>= \a' -> return (a',us) | otherwise = parseField fields unrec (a,us) (F line f val) parseField [] unrec (a,us) (F l f val) = return $ case unrec (f,val) a of -- no fields matched, see if the 'unrec' Just a' -> (a',us) -- function wants to do anything with it Nothing -> (a, ((l,f):us)) parseField _ _ _ _ = bug "'parseField' called on a non-field" deprecatedFields :: [(String,String)] deprecatedFields = deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo deprecatedFieldsPkgDescr :: [(String,String)] deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] deprecatedFieldsBuildInfo :: [(String,String)] deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] -- Handle deprecated fields deprecField :: Field -> ParseResult Field deprecField (F line fld val) = do fld' <- case lookup fld deprecatedFields of Nothing -> return fld Just newName -> do warning $ "The field \"" ++ fld ++ "\" is deprecated, please use \"" ++ newName ++ "\"" return newName return (F line fld' val) deprecField _ = bug "'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 (_:_) = bug "`parseExe' called on a non-field" parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st -- | Parse a configuration condition from a string. parseCondition :: Parse.ReadP r (Condition ConfVar) parseCondition = condOr where condOr = Parse.sepBy1 condAnd (oper "||") >>= return . foldl1 COr condAnd = Parse.sepBy1 cond (oper "&&")>>= return . foldl1 CAnd cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond +++ archCond +++ flagCond +++ implCond ) inparens = Parse.between (Parse.char '(' >> sp) (sp >> Parse.char ')' >> sp) notCond = Parse.char '!' >> sp >> cond >>= return . CNot osCond = Parse.string "os" >> sp >> inparens osIdent >>= return . Var archCond = Parse.string "arch" >> sp >> inparens archIdent >>= return . Var flagCond = Parse.string "flag" >> sp >> inparens flagIdent >>= return . Var implCond = Parse.string "impl" >> sp >> inparens implIdent >>= return . Var boolLiteral = fmap Lit parse archIdent = fmap Arch parse osIdent = fmap OS parse flagIdent = fmap (Flag . FlagName . lowercase) (Parse.munch1 isIdentChar) isIdentChar c = Char.isAlphaNum c || c == '_' || c == '-' oper s = sp >> Parse.string s >> sp sp = Parse.skipSpaces implIdent = do i <- parse vr <- sp >> Parse.option AnyVersion parse return $ Impl i vr -- --------------------------------------------------------------------------- -- Pretty printing writePackageDescription :: FilePath -> PackageDescription -> IO () writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) showPackageDescription :: PackageDescription -> String showPackageDescription pkg = render $ ppFields pkg pkgDescrFieldDescrs $$ ppCustomFields (customFieldsPD pkg) $$ (case library pkg of Nothing -> empty Just lib -> ppFields lib libFieldDescrs) $$ vcat (map ppExecutable (executables pkg)) where ppExecutable exe = space $$ ppFields exe 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 pbi = writeFile fpath (showHookedBuildInfo pbi) showHookedBuildInfo :: HookedBuildInfo -> String showHookedBuildInfo (mb_lib_bi, ex_bi) = render $ (case mb_lib_bi of Nothing -> empty Just bi -> ppFields bi binfoFieldDescrs) $$ vcat (map ppExeBuildInfo ex_bi) where ppExeBuildInfo (name, bi) = space $$ text "executable:" <+> text name $$ ppFields bi binfoFieldDescrs $$ ppCustomFields (customFieldsBI bi) -- replace all tabs used as indentation with whitespace, also return where -- tabs were found findIndentTabs :: String -> [(Int,Int)] findIndentTabs = concatMap checkLine . zip [1..] . lines where checkLine (lineno, l) = let (indent, _content) = span Char.isSpace l tabCols = map fst . filter ((== '\t') . snd) . zip [0..] addLineNo = map (\col -> (lineno,col)) in addLineNo (tabCols indent) --test_findIndentTabs = findIndentTabs $ unlines $ -- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] bug :: String -> a bug msg = error $ msg ++ ". Consider this a bug."