module Distribution.PackageDescription (
PackageDescription(..),
emptyPackageDescription,
specVersion,
descCabalVersion,
BuildType(..),
knownBuildTypes,
Library(..),
emptyLibrary,
withLib,
hasLibs,
libModules,
Executable(..),
emptyExecutable,
withExe,
hasExes,
exeModules,
TestSuite(..),
TestSuiteInterface(..),
TestType(..),
testType,
knownTestTypes,
emptyTestSuite,
hasTests,
withTest,
testModules,
enabledTests,
Benchmark(..),
BenchmarkInterface(..),
BenchmarkType(..),
benchmarkType,
knownBenchmarkTypes,
emptyBenchmark,
hasBenchmarks,
withBenchmark,
benchmarkModules,
enabledBenchmarks,
BuildInfo(..),
emptyBuildInfo,
allBuildInfo,
allLanguages,
allExtensions,
usedExtensions,
hcOptions,
HookedBuildInfo,
emptyHookedBuildInfo,
updatePackageDescription,
GenericPackageDescription(..),
Flag(..), FlagName(..), FlagAssignment,
CondTree(..), ConfVar(..), Condition(..),
SourceRepo(..),
RepoKind(..),
RepoType(..),
knownRepoTypes,
) where
import Data.Data (Data)
import Data.List (nub, intercalate)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Monoid (Monoid(mempty, mappend))
import Data.Typeable ( Typeable )
import Control.Monad (MonadPlus(mplus))
import Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)
import Distribution.Package
( PackageName(PackageName), PackageIdentifier(PackageIdentifier)
, Dependency, Package(..) )
import Distribution.ModuleName ( ModuleName )
import Distribution.Version
( Version(Version), VersionRange, anyVersion, orLaterVersion
, asVersionIntervals, LowerBound(..) )
import Distribution.License (License(AllRightsReserved))
import Distribution.Compiler (CompilerFlavor)
import Distribution.System (OS, Arch)
import Distribution.Text
( Text(..), display )
import Language.Haskell.Extension
( Language, Extension )
data PackageDescription
= PackageDescription {
package :: PackageIdentifier,
license :: License,
licenseFile :: FilePath,
copyright :: String,
maintainer :: String,
author :: String,
stability :: String,
testedWith :: [(CompilerFlavor,VersionRange)],
homepage :: String,
pkgUrl :: String,
bugReports :: String,
sourceRepos :: [SourceRepo],
synopsis :: String,
description :: String,
category :: String,
customFieldsPD :: [(String,String)],
buildDepends :: [Dependency],
specVersionRaw :: Either Version VersionRange,
buildType :: Maybe BuildType,
library :: Maybe Library,
executables :: [Executable],
testSuites :: [TestSuite],
benchmarks :: [Benchmark],
dataFiles :: [FilePath],
dataDir :: FilePath,
extraSrcFiles :: [FilePath],
extraTmpFiles :: [FilePath],
extraDocFiles :: [FilePath]
}
deriving (Show, Read, Eq, Typeable, Data)
instance Package PackageDescription where
packageId = package
specVersion :: PackageDescription -> Version
specVersion pkg = case specVersionRaw pkg of
Left version -> version
Right versionRange -> case asVersionIntervals versionRange of
[] -> Version [0] []
((LowerBound version _, _):_) -> version
descCabalVersion :: PackageDescription -> VersionRange
descCabalVersion pkg = case specVersionRaw pkg of
Left version -> orLaterVersion version
Right versionRange -> versionRange
emptyPackageDescription :: PackageDescription
emptyPackageDescription
= PackageDescription {
package = PackageIdentifier (PackageName "")
(Version [] []),
license = AllRightsReserved,
licenseFile = "",
specVersionRaw = Right anyVersion,
buildType = Nothing,
copyright = "",
maintainer = "",
author = "",
stability = "",
testedWith = [],
buildDepends = [],
homepage = "",
pkgUrl = "",
bugReports = "",
sourceRepos = [],
synopsis = "",
description = "",
category = "",
customFieldsPD = [],
library = Nothing,
executables = [],
testSuites = [],
benchmarks = [],
dataFiles = [],
dataDir = "",
extraSrcFiles = [],
extraTmpFiles = [],
extraDocFiles = []
}
data BuildType
= Simple
| Configure
| Make
| Custom
| UnknownBuildType String
deriving (Show, Read, Eq, Typeable, Data)
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
data Library = Library {
exposedModules :: [ModuleName],
libExposed :: Bool,
libBuildInfo :: BuildInfo
}
deriving (Show, Eq, Read, Typeable, Data)
instance Monoid Library where
mempty = Library {
exposedModules = mempty,
libExposed = True,
libBuildInfo = mempty
}
mappend a b = Library {
exposedModules = combine exposedModules,
libExposed = libExposed a && libExposed b,
libBuildInfo = combine libBuildInfo
}
where combine field = field a `mappend` field b
emptyLibrary :: Library
emptyLibrary = mempty
hasLibs :: PackageDescription -> Bool
hasLibs p = maybe False (buildable . libBuildInfo) (library p)
maybeHasLibs :: PackageDescription -> Maybe Library
maybeHasLibs p =
library p >>= \lib -> if buildable (libBuildInfo lib)
then Just lib
else Nothing
withLib :: PackageDescription -> (Library -> IO ()) -> IO ()
withLib pkg_descr f =
maybe (return ()) f (maybeHasLibs pkg_descr)
libModules :: Library -> [ModuleName]
libModules lib = exposedModules lib
++ otherModules (libBuildInfo lib)
data Executable = Executable {
exeName :: String,
modulePath :: FilePath,
buildInfo :: BuildInfo
}
deriving (Show, Read, Eq, Typeable, Data)
instance Monoid Executable where
mempty = Executable {
exeName = mempty,
modulePath = mempty,
buildInfo = mempty
}
mappend a b = Executable{
exeName = combine' exeName,
modulePath = combine modulePath,
buildInfo = combine buildInfo
}
where combine field = field a `mappend` field b
combine' field = case (field a, field b) of
("","") -> ""
("", x) -> x
(x, "") -> x
(x, y) -> error $ "Ambiguous values for executable field: '"
++ x ++ "' and '" ++ y ++ "'"
emptyExecutable :: Executable
emptyExecutable = mempty
hasExes :: PackageDescription -> Bool
hasExes p = any (buildable . buildInfo) (executables p)
withExe :: PackageDescription -> (Executable -> IO ()) -> IO ()
withExe pkg_descr f =
sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)]
exeModules :: Executable -> [ModuleName]
exeModules exe = otherModules (buildInfo exe)
data TestSuite = TestSuite {
testName :: String,
testInterface :: TestSuiteInterface,
testBuildInfo :: BuildInfo,
testEnabled :: Bool
}
deriving (Show, Read, Eq, Typeable, Data)
data TestSuiteInterface =
TestSuiteExeV10 Version FilePath
| TestSuiteLibV09 Version ModuleName
| TestSuiteUnsupported TestType
deriving (Eq, Read, Show, Typeable, Data)
instance Monoid TestSuite where
mempty = TestSuite {
testName = mempty,
testInterface = mempty,
testBuildInfo = mempty,
testEnabled = False
}
mappend a b = TestSuite {
testName = combine' testName,
testInterface = combine testInterface,
testBuildInfo = combine testBuildInfo,
testEnabled = testEnabled a || testEnabled b
}
where combine field = field a `mappend` field b
combine' f = case (f a, f b) of
("", x) -> x
(x, "") -> x
(x, y) -> error "Ambiguous values for test field: '"
++ x ++ "' and '" ++ y ++ "'"
instance Monoid TestSuiteInterface where
mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))
mappend a (TestSuiteUnsupported _) = a
mappend _ b = b
emptyTestSuite :: TestSuite
emptyTestSuite = mempty
hasTests :: PackageDescription -> Bool
hasTests = any (buildable . testBuildInfo) . testSuites
enabledTests :: PackageDescription -> [TestSuite]
enabledTests = filter testEnabled . testSuites
withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()
withTest pkg_descr f =
mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr
testModules :: TestSuite -> [ModuleName]
testModules test = (case testInterface test of
TestSuiteLibV09 _ m -> [m]
_ -> [])
++ otherModules (testBuildInfo test)
data TestType = TestTypeExe Version
| TestTypeLib Version
| TestTypeUnknown String Version
deriving (Show, Read, Eq, Typeable, Data)
knownTestTypes :: [TestType]
knownTestTypes = [ TestTypeExe (Version [1,0] [])
, TestTypeLib (Version [0,9] []) ]
stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res
stdParse f = do
cs <- Parse.sepBy1 component (Parse.char '-')
_ <- Parse.char '-'
ver <- parse
let name = intercalate "-" cs
return $! f ver (lowercase name)
where
component = do
cs <- Parse.munch1 Char.isAlphaNum
if all Char.isDigit cs then Parse.pfail else return cs
instance Text TestType where
disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver
disp (TestTypeLib ver) = text "detailed-" <> disp ver
disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver
parse = stdParse $ \ver name -> case name of
"exitcode-stdio" -> TestTypeExe ver
"detailed" -> TestTypeLib ver
_ -> TestTypeUnknown name ver
testType :: TestSuite -> TestType
testType test = case testInterface test of
TestSuiteExeV10 ver _ -> TestTypeExe ver
TestSuiteLibV09 ver _ -> TestTypeLib ver
TestSuiteUnsupported testtype -> testtype
data Benchmark = Benchmark {
benchmarkName :: String,
benchmarkInterface :: BenchmarkInterface,
benchmarkBuildInfo :: BuildInfo,
benchmarkEnabled :: Bool
}
deriving (Show, Read, Eq, Typeable, Data)
data BenchmarkInterface =
BenchmarkExeV10 Version FilePath
| BenchmarkUnsupported BenchmarkType
deriving (Eq, Read, Show, Typeable, Data)
instance Monoid Benchmark where
mempty = Benchmark {
benchmarkName = mempty,
benchmarkInterface = mempty,
benchmarkBuildInfo = mempty,
benchmarkEnabled = False
}
mappend a b = Benchmark {
benchmarkName = combine' benchmarkName,
benchmarkInterface = combine benchmarkInterface,
benchmarkBuildInfo = combine benchmarkBuildInfo,
benchmarkEnabled = benchmarkEnabled a || benchmarkEnabled b
}
where combine field = field a `mappend` field b
combine' f = case (f a, f b) of
("", x) -> x
(x, "") -> x
(x, y) -> error "Ambiguous values for benchmark field: '"
++ x ++ "' and '" ++ y ++ "'"
instance Monoid BenchmarkInterface where
mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] []))
mappend a (BenchmarkUnsupported _) = a
mappend _ b = b
emptyBenchmark :: Benchmark
emptyBenchmark = mempty
hasBenchmarks :: PackageDescription -> Bool
hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks
enabledBenchmarks :: PackageDescription -> [Benchmark]
enabledBenchmarks = filter benchmarkEnabled . benchmarks
withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()
withBenchmark pkg_descr f =
mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr
benchmarkModules :: Benchmark -> [ModuleName]
benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)
data BenchmarkType = BenchmarkTypeExe Version
| BenchmarkTypeUnknown String Version
deriving (Show, Read, Eq, Typeable, Data)
knownBenchmarkTypes :: [BenchmarkType]
knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]
instance Text BenchmarkType where
disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <> disp ver
disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver
parse = stdParse $ \ver name -> case name of
"exitcode-stdio" -> BenchmarkTypeExe ver
_ -> BenchmarkTypeUnknown name ver
benchmarkType :: Benchmark -> BenchmarkType
benchmarkType benchmark = case benchmarkInterface benchmark of
BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver
BenchmarkUnsupported benchmarktype -> benchmarktype
data BuildInfo = BuildInfo {
buildable :: Bool,
buildTools :: [Dependency],
cppOptions :: [String],
ccOptions :: [String],
ldOptions :: [String],
pkgconfigDepends :: [Dependency],
frameworks :: [String],
cSources :: [FilePath],
hsSourceDirs :: [FilePath],
otherModules :: [ModuleName],
defaultLanguage :: Maybe Language,
otherLanguages :: [Language],
defaultExtensions :: [Extension],
otherExtensions :: [Extension],
oldExtensions :: [Extension],
extraLibs :: [String],
extraLibDirs :: [String],
includeDirs :: [FilePath],
includes :: [FilePath],
installIncludes :: [FilePath],
options :: [(CompilerFlavor,[String])],
ghcProfOptions :: [String],
ghcSharedOptions :: [String],
customFieldsBI :: [(String,String)],
targetBuildDepends :: [Dependency]
}
deriving (Show,Read,Eq,Typeable,Data)
instance Monoid BuildInfo where
mempty = BuildInfo {
buildable = True,
buildTools = [],
cppOptions = [],
ccOptions = [],
ldOptions = [],
pkgconfigDepends = [],
frameworks = [],
cSources = [],
hsSourceDirs = [],
otherModules = [],
defaultLanguage = Nothing,
otherLanguages = [],
defaultExtensions = [],
otherExtensions = [],
oldExtensions = [],
extraLibs = [],
extraLibDirs = [],
includeDirs = [],
includes = [],
installIncludes = [],
options = [],
ghcProfOptions = [],
ghcSharedOptions = [],
customFieldsBI = [],
targetBuildDepends = []
}
mappend a b = BuildInfo {
buildable = buildable a && buildable b,
buildTools = combine buildTools,
cppOptions = combine cppOptions,
ccOptions = combine ccOptions,
ldOptions = combine ldOptions,
pkgconfigDepends = combine pkgconfigDepends,
frameworks = combineNub frameworks,
cSources = combineNub cSources,
hsSourceDirs = combineNub hsSourceDirs,
otherModules = combineNub otherModules,
defaultLanguage = combineMby defaultLanguage,
otherLanguages = combineNub otherLanguages,
defaultExtensions = combineNub defaultExtensions,
otherExtensions = combineNub otherExtensions,
oldExtensions = combineNub oldExtensions,
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,
targetBuildDepends = combineNub targetBuildDepends
}
where
combine field = field a `mappend` field b
combineNub field = nub (combine field)
combineMby field = field b `mplus` field a
emptyBuildInfo :: BuildInfo
emptyBuildInfo = mempty
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 ]
++ [ bi | tst <- testSuites pkg_descr
, let bi = testBuildInfo tst
, buildable bi
, testEnabled tst ]
++ [ bi | tst <- benchmarks pkg_descr
, let bi = benchmarkBuildInfo tst
, buildable bi
, benchmarkEnabled tst ]
allLanguages :: BuildInfo -> [Language]
allLanguages bi = maybeToList (defaultLanguage bi)
++ otherLanguages bi
allExtensions :: BuildInfo -> [Extension]
allExtensions bi = usedExtensions bi
++ otherExtensions bi
usedExtensions :: BuildInfo -> [Extension]
usedExtensions bi = oldExtensions bi
++ defaultExtensions bi
type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)])
emptyHookedBuildInfo :: HookedBuildInfo
emptyHookedBuildInfo = (Nothing, [])
hcOptions :: CompilerFlavor -> BuildInfo -> [String]
hcOptions hc bi = [ opt | (hc',opts) <- options bi
, hc' == hc
, opt <- opts ]
data SourceRepo = SourceRepo {
repoKind :: RepoKind,
repoType :: Maybe RepoType,
repoLocation :: Maybe String,
repoModule :: Maybe String,
repoBranch :: Maybe String,
repoTag :: Maybe String,
repoSubdir :: Maybe FilePath
}
deriving (Eq, Read, Show, Typeable, Data)
data RepoKind =
RepoHead
| RepoThis
| RepoKindUnknown String
deriving (Eq, Ord, Read, Show, Typeable, Data)
data RepoType = Darcs | Git | SVN | CVS
| Mercurial | GnuArch | Bazaar | Monotone
| OtherRepoType String
deriving (Eq, Ord, Read, Show, Typeable, Data)
knownRepoTypes :: [RepoType]
knownRepoTypes = [Darcs, Git, SVN, CVS
,Mercurial, GnuArch, Bazaar, Monotone]
repoTypeAliases :: RepoType -> [String]
repoTypeAliases Bazaar = ["bzr"]
repoTypeAliases Mercurial = ["hg"]
repoTypeAliases GnuArch = ["arch"]
repoTypeAliases _ = []
instance Text RepoKind where
disp RepoHead = Disp.text "head"
disp RepoThis = Disp.text "this"
disp (RepoKindUnknown other) = Disp.text other
parse = do
name <- ident
return $ case lowercase name of
"head" -> RepoHead
"this" -> RepoThis
_ -> RepoKindUnknown name
instance Text RepoType where
disp (OtherRepoType other) = Disp.text other
disp other = Disp.text (lowercase (show other))
parse = fmap classifyRepoType ident
classifyRepoType :: String -> RepoType
classifyRepoType s =
fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap
where
repoTypeMap = [ (name, repoType')
| repoType' <- knownRepoTypes
, name <- display repoType' : repoTypeAliases repoType' ]
ident :: Parse.ReadP r String
ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
lowercase :: String -> String
lowercase = map Char.toLower
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 = bi `mappend` libBuildInfo lib})
updateLibrary Nothing mb_lib = mb_lib
updateLibrary (Just _) Nothing = Nothing
updateExecutables :: [(String, BuildInfo)]
-> [Executable]
-> [Executable]
updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi'
updateExecutable :: (String, BuildInfo)
-> [Executable]
-> [Executable]
updateExecutable _ [] = []
updateExecutable exe_bi'@(name,bi) (exe:exes)
| exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes
| otherwise = exe : updateExecutable exe_bi' exes
data GenericPackageDescription =
GenericPackageDescription {
packageDescription :: PackageDescription,
genPackageFlags :: [Flag],
condLibrary :: Maybe (CondTree ConfVar [Dependency] Library),
condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)],
condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)],
condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)]
}
deriving (Show, Eq, Typeable, Data)
instance Package GenericPackageDescription where
packageId = packageId . packageDescription
data Flag = MkFlag
{ flagName :: FlagName
, flagDescription :: String
, flagDefault :: Bool
, flagManual :: Bool
}
deriving (Show, Eq, Typeable, Data)
newtype FlagName = FlagName String
deriving (Eq, Ord, Show, Read, Typeable, Data)
type FlagAssignment = [(FlagName, Bool)]
data ConfVar = OS OS
| Arch Arch
| Flag FlagName
| Impl CompilerFlavor VersionRange
deriving (Eq, Show, Typeable, Data)
data Condition c = Var c
| Lit Bool
| CNot (Condition c)
| COr (Condition c) (Condition c)
| CAnd (Condition c) (Condition c)
deriving (Show, Eq, Typeable, Data)
data CondTree v c a = CondNode
{ condTreeData :: a
, condTreeConstraints :: c
, condTreeComponents :: [( Condition v
, CondTree v c a
, Maybe (CondTree v c a))]
}
deriving (Show, Eq, Typeable, Data)