Commits (76)
name: Cabal
version: 1.21.1.0
version: 1.22.0.0
copyright: 2003-2006, Isaac Jones
2005-2011, Duncan Coutts
license: BSD3
......@@ -180,6 +180,7 @@ library
Distribution.Simple.Compiler
Distribution.Simple.Configure
Distribution.Simple.GHC
Distribution.Simple.GHCJS
Distribution.Simple.Haddock
Distribution.Simple.HaskellSuite
Distribution.Simple.Hpc
......@@ -226,8 +227,10 @@ library
Distribution.Compat.CopyFile
Distribution.Compat.TempFile
Distribution.GetOpt
Distribution.Simple.GHC.Internal
Distribution.Simple.GHC.IPI641
Distribution.Simple.GHC.IPI642
Distribution.Simple.GHC.ImplInfo
Paths_Cabal
default-language: Haskell98
......
......@@ -15,6 +15,7 @@ import GHC.IO.FD (mkFD)
import GHC.IO.Device (IODeviceType(Stream))
import GHC.IO.Handle.FD (mkHandleFromFD)
import System.IO (IOMode(ReadMode, WriteMode))
#elif ghcjs_HOST_OS
#else
import System.Posix.IO (fdToHandle)
import qualified System.Posix.IO as Posix
......@@ -48,6 +49,8 @@ foreign import ccall "io.h _pipe" c__pipe ::
foreign import ccall "io.h _close" c__close ::
CInt -> IO CInt
#elif ghcjs_HOST_OS
createPipe = error "createPipe"
#else
createPipe = do
(readfd, writefd) <- Posix.createPipe
......
......@@ -25,7 +25,7 @@ import Foreign.C (getErrno, errnoToIOError)
import System.Posix.Internals (c_getpid)
#ifdef mingw32_HOST_OS
#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
import System.Directory ( createDirectory )
#else
import qualified System.Posix
......@@ -121,7 +121,7 @@ createTempDirectory dir template = do
| otherwise -> ioError e
mkPrivateDir :: String -> IO ()
#ifdef mingw32_HOST_OS
#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
mkPrivateDir s = createDirectory s
#else
mkPrivateDir s = System.Posix.createDirectory s 0o700
......
......@@ -35,6 +35,11 @@ module Distribution.Compiler (
-- * Compiler id
CompilerId(..),
-- * Compiler info
CompilerInfo(..),
unknownCompilerInfo,
AbiTag(..), abiTagString
) where
import Data.Binary (Binary)
......@@ -44,6 +49,8 @@ import Data.Maybe (fromMaybe)
import Distribution.Version (Version(..))
import GHC.Generics (Generic)
import Language.Haskell.Extension (Language, Extension)
import qualified System.Info (compilerName, compilerVersion)
import Distribution.Text (Text(..), display)
import qualified Distribution.Compat.ReadP as Parse
......@@ -53,7 +60,7 @@ import Text.PrettyPrint ((<>))
import qualified Data.Char as Char (toLower, isDigit, isAlphaNum)
import Control.Monad (when)
data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC
data CompilerFlavor = GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC
| HaskellSuite String -- string is the id of the actual compiler
| OtherCompiler String
deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
......@@ -61,7 +68,7 @@ data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC
instance Binary CompilerFlavor
knownCompilerFlavors :: [CompilerFlavor]
knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
instance Text CompilerFlavor where
disp (OtherCompiler name) = Disp.text name
......@@ -146,3 +153,52 @@ instance Text CompilerId where
lowercase :: String -> String
lowercase = map Char.toLower
-- ------------------------------------------------------------
-- * Compiler Info
-- ------------------------------------------------------------
-- | Compiler information used for resolving configurations. Some fields can be
-- set to Nothing to indicate that the information is unknown.
data CompilerInfo = CompilerInfo {
compilerInfoId :: CompilerId,
-- ^ Compiler flavour and version.
compilerInfoAbiTag :: AbiTag,
-- ^ Tag for distinguishing incompatible ABI's on the same architecture/os.
compilerInfoCompat :: Maybe [CompilerId],
-- ^ Other implementations that this compiler claims to be compatible with, if known.
compilerInfoLanguages :: Maybe [Language],
-- ^ Supported language standards, if known.
compilerInfoExtensions :: Maybe [Extension]
-- ^ Supported extensions, if known.
}
deriving (Generic, Show, Read)
instance Binary CompilerInfo
data AbiTag
= NoAbiTag
| AbiTag String
deriving (Generic, Show, Read)
instance Binary AbiTag
instance Text AbiTag where
disp NoAbiTag = Disp.empty
disp (AbiTag tag) = Disp.text tag
parse = do
tag <- Parse.munch (\c -> Char.isAlphaNum c || c == '_')
if null tag then return NoAbiTag else return (AbiTag tag)
abiTagString :: AbiTag -> String
abiTagString NoAbiTag = ""
abiTagString (AbiTag tag) = tag
-- | Make a CompilerInfo of which only the known information is its CompilerId,
-- its AbiTag and that it does not claim to be compatible with other
-- compiler id's.
unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo
unknownCompilerInfo compilerId abiTag =
CompilerInfo compilerId abiTag (Just []) Nothing Nothing
......@@ -61,7 +61,8 @@ import Distribution.Text
import Text.PrettyPrint as Disp
import qualified Distribution.Compat.ReadP as Parse
import Data.Binary (Binary)
import Data.Binary (Binary)
import Data.Maybe (fromMaybe)
import GHC.Generics (Generic)
-- -----------------------------------------------------------------------------
......@@ -104,7 +105,8 @@ data InstalledPackageInfo_ m
frameworkDirs :: [FilePath],
frameworks :: [String],
haddockInterfaces :: [FilePath],
haddockHTMLs :: [FilePath]
haddockHTMLs :: [FilePath],
pkgRoot :: Maybe FilePath
}
deriving (Generic, Read, Show)
......@@ -155,7 +157,8 @@ emptyInstalledPackageInfo
frameworkDirs = [],
frameworks = [],
haddockInterfaces = [],
haddockHTMLs = []
haddockHTMLs = [],
pkgRoot = Nothing
}
noVersion :: Version
......@@ -375,6 +378,9 @@ installedFieldDescrs = [
, listField "haddock-html"
showFilePath parseFilePathQ
haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs})
, simpleField "pkgroot"
(const Disp.empty) parseFilePathQ
(fromMaybe "" . pkgRoot) (\xs pkg -> pkg{pkgRoot=Just xs})
]
deprecatedFieldDescrs :: [FieldDescr InstalledPackageInfo]
......
......@@ -92,7 +92,7 @@ defaultMainNoRead = const defaultMain
defaultMainHelper :: [String] -> IO ()
defaultMainHelper args =
case commandsRun globalCommand commands args of
case commandsRun (globalCommand commands) commands args of
CommandHelp help -> printHelp help
CommandList opts -> printOptionsList opts
CommandErrors errs -> printErrors errs
......
......@@ -85,6 +85,8 @@ module Distribution.PackageDescription (
allExtensions,
usedExtensions,
hcOptions,
hcProfOptions,
hcSharedOptions,
-- ** Supplementary build information
HookedBuildInfo,
......@@ -765,6 +767,7 @@ data BuildInfo = BuildInfo {
pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used
frameworks :: [String], -- ^support frameworks for Mac OS X
cSources :: [FilePath],
jsSources :: [FilePath],
hsSourceDirs :: [FilePath], -- ^ where to look for the Haskell module hierarchy
otherModules :: [ModuleName], -- ^ non-exposed or non-main modules
......@@ -781,8 +784,8 @@ data BuildInfo = BuildInfo {
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],
profOptions :: [(CompilerFlavor,[String])],
sharedOptions :: [(CompilerFlavor,[String])],
customFieldsBI :: [(String,String)], -- ^Custom fields starting
-- with x-, stored in a
-- simple assoc-list.
......@@ -803,6 +806,7 @@ instance Monoid BuildInfo where
pkgconfigDepends = [],
frameworks = [],
cSources = [],
jsSources = [],
hsSourceDirs = [],
otherModules = [],
defaultLanguage = Nothing,
......@@ -817,8 +821,8 @@ instance Monoid BuildInfo where
includes = [],
installIncludes = [],
options = [],
ghcProfOptions = [],
ghcSharedOptions = [],
profOptions = [],
sharedOptions = [],
customFieldsBI = [],
targetBuildDepends = [],
targetBuildRenaming = Map.empty
......@@ -832,6 +836,7 @@ instance Monoid BuildInfo where
pkgconfigDepends = combine pkgconfigDepends,
frameworks = combineNub frameworks,
cSources = combineNub cSources,
jsSources = combineNub jsSources,
hsSourceDirs = combineNub hsSourceDirs,
otherModules = combineNub otherModules,
defaultLanguage = combineMby defaultLanguage,
......@@ -846,8 +851,8 @@ instance Monoid BuildInfo where
includes = combineNub includes,
installIncludes = combineNub installIncludes,
options = combine options,
ghcProfOptions = combine ghcProfOptions,
ghcSharedOptions = combine ghcSharedOptions,
profOptions = combine profOptions,
sharedOptions = combine sharedOptions,
customFieldsBI = combine customFieldsBI,
targetBuildDepends = combineNub targetBuildDepends,
targetBuildRenaming = combineMap targetBuildRenaming
......@@ -907,9 +912,19 @@ 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 ]
hcOptions = lookupHcOptions options
hcProfOptions :: CompilerFlavor -> BuildInfo -> [String]
hcProfOptions = lookupHcOptions profOptions
hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String]
hcSharedOptions = lookupHcOptions sharedOptions
lookupHcOptions :: (BuildInfo -> [(CompilerFlavor,[String])])
-> CompilerFlavor -> BuildInfo -> [String]
lookupHcOptions f hc bi = [ opt | (hc',opts) <- f bi
, hc' == hc
, opt <- opts ]
-- ------------------------------------------------------------
-- * Source repos
......
......@@ -46,7 +46,8 @@ import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
( flattenPackageDescription, finalizePackageDescription )
import Distribution.Compiler
( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) )
( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..)
, unknownCompilerInfo, AbiTag(..) )
import Distribution.System
( OS(..), Arch(..), buildPlatform )
import Distribution.License
......@@ -724,7 +725,7 @@ checkGhcOptions pkg =
has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options
(ghc_options, ghc_prof_options) =
unzip . map (\bi -> (hcOptions GHC bi, ghcProfOptions bi))
unzip . map (\bi -> (hcOptions GHC bi, hcProfOptions GHC bi))
$ (allBuildInfo pkg)
all_ghc_options = concat ghc_options
all_ghc_prof_options = concat ghc_prof_options
......@@ -878,6 +879,7 @@ checkPaths pkg =
++ [ (path, "data-dir") | path <- [dataDir pkg]]
++ concat
[ [ (path, "c-sources") | path <- cSources bi ]
++ [ (path, "js-sources") | path <- jsSources bi ]
++ [ (path, "install-includes") | path <- installIncludes bi ]
++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ]
| bi <- allBuildInfo pkg ]
......@@ -1285,7 +1287,8 @@ checkPackageVersions pkg =
-- using no package index and the current platform.
finalised = finalizePackageDescription
[] (const True) buildPlatform
(CompilerId buildCompilerFlavor (Version [] []))
(unknownCompilerInfo
(CompilerId buildCompilerFlavor (Version [] [])) NoAbiTag)
[] pkg
baseDependency = case finalised of
Right (pkg', _) | not (null baseDeps) ->
......
......@@ -46,6 +46,8 @@ import Distribution.System
( Platform(..), OS, Arch )
import Distribution.Simple.Utils
( currentDir, lowercase )
import Distribution.Simple.Compiler
( CompilerInfo(..) )
import Distribution.Text
( Text(parse) )
......@@ -97,16 +99,23 @@ simplifyCondition cond i = fv . walk $ cond
-- | Simplify a configuration condition using the OS and arch names. Returns
-- the names of all the flags occurring in the condition.
simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar
simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar
-> (Condition FlagName, [FlagName])
simplifyWithSysParams os arch (CompilerId comp compVer) cond = (cond', flags)
simplifyWithSysParams os arch cinfo cond = (cond', flags)
where
(cond', flags) = simplifyCondition cond interp
interp (OS os') = Right $ os' == os
interp (Arch arch') = Right $ arch' == arch
interp (Impl comp' vr) = Right $ comp' == comp
&& compVer `withinRange` vr
interp (Flag f) = Left f
interp (Impl comp vr)
| matchImpl (compilerInfoId cinfo) = Right True
| otherwise = case compilerInfoCompat cinfo of
-- fixme: treat Nothing as unknown, rather than empty list once we
-- support partial resolution of system parameters
Nothing -> Right False
Just compat -> Right (any matchImpl compat)
where
matchImpl (CompilerId c v) = comp == c && v `withinRange` vr
interp (Flag f) = Left f
-- TODO: Add instances and check
--
......@@ -208,7 +217,7 @@ resolveWithFlags ::
-- ^ Domain for each flag name, will be tested in order.
-> OS -- ^ OS as returned by Distribution.System.buildOS
-> Arch -- ^ Arch as returned by Distribution.System.buildArch
-> CompilerId -- ^ Compiler flavour + version
-> CompilerInfo -- ^ Compiler information
-> [Dependency] -- ^ Additional constraints
-> [CondTree ConfVar [Dependency] PDTagged]
-> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function.
......@@ -463,7 +472,7 @@ finalizePackageDescription ::
-- available packages? If this is unknown then use
-- True.
-> Platform -- ^ The 'Arch' and 'OS'
-> CompilerId -- ^ Compiler + Version
-> CompilerInfo -- ^ Compiler information
-> [Dependency] -- ^ Additional constraints
-> GenericPackageDescription
-> Either [Dependency]
......
......@@ -418,7 +418,9 @@ binfoFieldDescrs =
, listFieldWithSep vcat "c-sources"
showFilePath parseFilePathQ
cSources (\paths binfo -> binfo{cSources=paths})
, listFieldWithSep vcat "js-sources"
showFilePath parseFilePathQ
jsSources (\paths binfo -> binfo{jsSources=paths})
, simpleField "default-language"
(maybe empty disp) (option Nothing (fmap Just parseLanguageQ))
defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang})
......@@ -459,14 +461,18 @@ binfoFieldDescrs =
, listFieldWithSep vcat "other-modules"
disp 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
ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=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})
......
......@@ -43,7 +43,7 @@ import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat)
import Distribution.License
import Distribution.Version
( Version(..), VersionRange, anyVersion )
import Distribution.Package ( PackageName(..), Dependency(..), InstalledPackageId )
import Distribution.Package ( PackageName(..), Dependency(..) )
import Distribution.ModuleName (ModuleName)
import Distribution.Compat.ReadP as ReadP hiding (get)
import Distribution.ReadE
......@@ -268,7 +268,7 @@ ppFields fields x =
vcat [ ppField name (getter x) | FieldDescr name getter _ <- fields ]
ppField :: String -> Doc -> Doc
ppField name fielddoc
ppField name fielddoc
| isEmpty fielddoc = empty
| name `elem` nestedFields = text name <> colon $+$ nest indentWith fielddoc
| otherwise = text name <> colon <+> fielddoc
......@@ -281,6 +281,7 @@ ppField name fielddoc
, "extra-tmp-files"
, "exposed-modules"
, "c-sources"
, "js-sources"
, "extra-libraries"
, "includes"
, "install-includes"
......
......@@ -143,7 +143,7 @@ defaultMainNoRead pkg_descr =
defaultMainHelper :: UserHooks -> Args -> IO ()
defaultMainHelper hooks args = topHandler $
case commandsRun globalCommand commands args of
case commandsRun (globalCommand commands) commands args of
CommandHelp help -> printHelp help
CommandList opts -> printOptionsList opts
CommandErrors errs -> printErrors errs
......
......@@ -19,7 +19,7 @@ import qualified Distribution.PackageDescription as PD
( PackageDescription(..), BuildInfo(buildable)
, Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks )
import Distribution.Simple.BuildPaths ( exeExtension )
import Distribution.Simple.Compiler ( Compiler(..) )
import Distribution.Simple.Compiler ( compilerInfo )
import Distribution.Simple.InstallDirs
( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
, substPathTemplate , toPathTemplate, PathTemplate )
......@@ -124,5 +124,5 @@ benchOption pkg_descr lbi bm template =
where
env = initialPathTemplateEnv
(PD.package pkg_descr) (LBI.pkgKey lbi)
(compilerId $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
(compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
[(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
......@@ -23,10 +23,11 @@ module Distribution.Simple.Build (
writeAutogenFiles,
) where
import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.JHC as JHC
import qualified Distribution.Simple.LHC as LHC
import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
import qualified Distribution.Simple.JHC as JHC
import qualified Distribution.Simple.LHC as LHC
import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import qualified Distribution.Simple.Build.Macros as Build.Macros
......@@ -46,7 +47,6 @@ import qualified Distribution.InstalledPackageInfo as IPI
import qualified Distribution.ModuleName as ModuleName
import Distribution.ModuleName (ModuleName)
import Distribution.Simple.Program (ghcPkgProgram)
import Distribution.Simple.Setup
( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag )
import Distribution.Simple.BuildTarget
......@@ -115,8 +115,7 @@ build pkg_descr lbi flags suffixes = do
-- Only bother with this message if we're building the whole package
setupMessage verbosity "Building" (packageId pkg_descr)
let Just ghcPkgProg = lookupProgram ghcPkgProgram (withPrograms lbi)
internalPackageDB <- createInternalPackageDB verbosity ghcPkgProg distPref
internalPackageDB <- createInternalPackageDB verbosity lbi distPref
withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->
let bi = componentBuildInfo comp
......@@ -153,8 +152,8 @@ repl pkg_descr lbi flags suffixes args = do
initialBuildSteps distPref pkg_descr lbi verbosity
let Just ghcPkgProg = lookupProgram ghcPkgProgram (withPrograms lbi)
internalPackageDB <- createInternalPackageDB verbosity ghcPkgProg distPref
internalPackageDB <- createInternalPackageDB verbosity lbi distPref
let lbiForComponent comp lbi' =
lbi' {
withPackageDB = withPackageDB lbi ++ [internalPackageDB],
......@@ -181,8 +180,9 @@ repl pkg_descr lbi flags suffixes args = do
startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO ()
startInterpreter verbosity programDb comp packageDBs =
case compilerFlavor comp of
GHC -> GHC.startInterpreter verbosity programDb comp packageDBs
_ -> die "A REPL is not supported with this compiler."
GHC -> GHC.startInterpreter verbosity programDb comp packageDBs
GHCJS -> GHCJS.startInterpreter verbosity programDb comp packageDBs
_ -> die "A REPL is not supported with this compiler."
buildComponent :: Verbosity
-> Flag (Maybe Int)
......@@ -440,14 +440,22 @@ benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind"
-- | Initialize a new package db file for libraries defined
-- internally to the package.
createInternalPackageDB :: Verbosity -> ConfiguredProgram -> FilePath -> IO PackageDB
createInternalPackageDB verbosity ghcPkgProg distPref = do
let dbDir = distPref </> "package.conf.inplace"
packageDB = SpecificPackageDB dbDir
exists <- doesDirectoryExist dbDir
when exists $ removeDirectoryRecursive dbDir
HcPkg.init verbosity ghcPkgProg dbDir
return packageDB
createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath
-> IO PackageDB
createInternalPackageDB verbosity lbi distPref = do
case compilerFlavor (compiler lbi) of
GHC -> createWith $ GHC.hcPkgInfo (withPrograms lbi)
GHCJS -> createWith $ GHCJS.hcPkgInfo (withPrograms lbi)
LHC -> createWith $ LHC.hcPkgInfo (withPrograms lbi)
_ -> return packageDB
where
dbDir = distPref </> "package.conf.inplace"
packageDB = SpecificPackageDB dbDir
createWith hpi = do
exists <- doesDirectoryExist dbDir
when exists $ removeDirectoryRecursive dbDir
HcPkg.init hpi verbosity dbDir
return packageDB
addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
-> ProgramDb -> ProgramDb
......@@ -472,10 +480,11 @@ buildLib :: Verbosity -> Flag (Maybe Int)
-> Library -> ComponentLocalBuildInfo -> IO ()
buildLib verbosity numJobs pkg_descr lbi lib clbi =
case compilerFlavor (compiler lbi) of
GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi
JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi
LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi
UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi
GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi
GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi
JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi
LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi
UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi
HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi
_ -> die "Building is not supported with this compiler."
......@@ -484,12 +493,12 @@ buildExe :: Verbosity -> Flag (Maybe Int)
-> Executable -> ComponentLocalBuildInfo -> IO ()
buildExe verbosity numJobs pkg_descr lbi exe clbi =
case compilerFlavor (compiler lbi) of
GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi
JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi
LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi
UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi
_ -> die "Building is not supported with this compiler."
GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi
GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi
JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi
LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi
UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi
_ -> die "Building is not supported with this compiler."
replLib :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO ()
......@@ -497,15 +506,17 @@ replLib verbosity pkg_descr lbi lib clbi =
case compilerFlavor (compiler lbi) of
-- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass
-- NoFlag as the numJobs parameter.
GHC -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi
_ -> die "A REPL is not supported for this compiler."
GHC -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi
GHCJS -> GHCJS.replLib verbosity NoFlag pkg_descr lbi lib clbi
_ -> die "A REPL is not supported for this compiler."
replExe :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Executable -> ComponentLocalBuildInfo -> IO ()
replExe verbosity pkg_descr lbi exe clbi =
case compilerFlavor (compiler lbi) of
GHC -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi
_ -> die "A REPL is not supported for this compiler."
GHC -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi
GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi
_ -> die "A REPL is not supported for this compiler."
initialBuildSteps :: FilePath -- ^"dist" prefix
......
......@@ -32,6 +32,8 @@ import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup ( CopyDest(NoCopyDest) )
import Distribution.Simple.BuildPaths
( autogenModuleName )
import Distribution.Simple.Utils
( shortRelativePath )
import Distribution.Text
( display )
import Distribution.Version
......@@ -62,6 +64,11 @@ generate pkg_descr lbi =
"import Foreign\n"++
"import Foreign.C\n"
reloc_imports
| reloc =
"import System.Environment (getExecutablePath)\n"
| otherwise = ""
header =
pragmas++
"module " ++ display paths_modulename ++ " (\n"++
......@@ -74,16 +81,36 @@ generate pkg_descr lbi =
"import qualified Control.Exception as Exception\n"++
"import Data.Version (Version(..))\n"++
"import System.Environment (getEnv)\n"++
reloc_imports ++
"import Prelude\n"++
"\n"++
"catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++
"catchIO = Exception.catch\n" ++
"\n"++
"\nversion :: Version"++
"version :: Version"++
"\nversion = Version " ++ show branch ++ " " ++ show tags
where Version branch tags = packageVersion pkg_descr
body
| reloc =
"\n\nbindirrel :: FilePath\n" ++
"bindirrel = " ++ show flat_bindirreloc ++
"\n"++
"\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++
"getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++
"getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++
"getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++
"getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++
"getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++
"\n"++
"getDataFileName :: FilePath -> IO FilePath\n"++
"getDataFileName name = do\n"++
" dir <- getDataDir\n"++
" return (dir `joinFileName` name)\n"++
"\n"++
get_prefix_reloc_stuff++
"\n"++
filename_stuff
| absolute =
"\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++
"\nbindir = " ++ show flat_bindir ++
......@@ -146,9 +173,20 @@ generate pkg_descr lbi =
sysconfdir = flat_sysconfdirrel
} = prefixRelativeInstallDirs (packageId pkg_descr) lbi
flat_bindirreloc = shortRelativePath flat_prefix flat_bindir
flat_libdirreloc = shortRelativePath flat_prefix flat_libdir
flat_datadirreloc = shortRelativePath flat_prefix flat_datadir
flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir
flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir
mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel
mkGetDir dir Nothing = "return " ++ show dir
mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" ++
" (\\_ -> getPrefixDirReloc \"" ++ dirrel ++
"\")"
where var' = pkgPathEnvVar pkg_descr var
mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++
" (\\_ -> "++expr++")"
where var' = pkgPathEnvVar pkg_descr var
......@@ -159,9 +197,14 @@ generate pkg_descr lbi =
|| isNothing flat_bindirrel -- if the bin dir is an absolute path
|| not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))
reloc = relocatable lbi
supportsRelocatableProgs GHC = case buildOS of
Windows -> True
_ -> False
supportsRelocatableProgs GHCJS = case buildOS of
Windows -> True
_ -> False
supportsRelocatableProgs _ = False
paths_modulename = autogenModuleName pkg_descr
......@@ -171,9 +214,10 @@ generate pkg_descr lbi =
path_sep = show [pathSeparator]
supports_language_pragma =
compilerFlavor (compiler lbi) == GHC &&
(compilerFlavor (compiler lbi) == GHC &&
(compilerVersion (compiler lbi)
`withinRange` orLaterVersion (Version [6,6,1] []))
`withinRange` orLaterVersion (Version [6,6,1] []))) ||
compilerFlavor (compiler lbi) == GHCJS
-- | Generates the name of the environment variable controlling the path
-- component of interest.
......@@ -188,6 +232,14 @@ pkgPathEnvVar pkg_descr var =
fixchar '-' = '_'
fixchar c = c
get_prefix_reloc_stuff :: String
get_prefix_reloc_stuff =
"getPrefixDirReloc :: FilePath -> IO FilePath\n"++
"getPrefixDirReloc dirRel = do\n"++
" exePath <- getExecutablePath\n"++
" let (bindir,_) = splitFileName exePath\n"++
" return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"
get_prefix_win32 :: Arch -> String
get_prefix_win32 arch =
"getPrefixDirRel :: FilePath -> IO FilePath\n"++
......
......@@ -426,7 +426,8 @@ data ComponentInfo = ComponentInfo {
cinfoSrcDirs :: [FilePath],
cinfoModules :: [ModuleName],
cinfoHsFiles :: [FilePath], -- other hs files (like main.hs)
cinfoCFiles :: [FilePath]
cinfoCFiles :: [FilePath],
cinfoJsFiles :: [FilePath]
}
type ComponentStringName = String
......@@ -439,7 +440,8 @@ pkgComponentInfo pkg =
cinfoSrcDirs = hsSourceDirs bi,
cinfoModules = componentModules c,
cinfoHsFiles = componentHsFiles c,
cinfoCFiles = cSources bi
cinfoCFiles = cSources bi,
cinfoJsFiles = jsSources bi
}
| c <- pkgComponents pkg
, let bi = componentBuildInfo c ]
......@@ -658,12 +660,14 @@ matchComponentFile c str fexists =
, matchOtherFileRooted dirs hsFiles str ])
(msum [ matchModuleFileUnrooted ms str
, matchOtherFileUnrooted hsFiles str
, matchOtherFileUnrooted cFiles str ]))
, matchOtherFileUnrooted cFiles str
, matchOtherFileUnrooted jsFiles str ]))
where
dirs = cinfoSrcDirs c
ms = cinfoModules c
hsFiles = cinfoHsFiles c
cFiles = cinfoCFiles c
jsFiles = cinfoJsFiles c
-- utils
......
......@@ -22,10 +22,14 @@ module Distribution.Simple.Command (
commandShowOptions,
CommandParse(..),
commandParseArgs,
getNormalCommandDescriptions,
helpCommandUI,
-- ** Constructing commands
ShowOrParseArgs(..),
makeCommand,
usageDefault,
usageAlternatives,
mkCommandUI,
hiddenCommand,
-- ** Associating actions with commands
......@@ -80,6 +84,8 @@ data CommandUI flags = CommandUI {
commandUsage :: String -> String,
-- | Additional explanation of the command to use in help texts.
commandDescription :: Maybe (String -> String),
-- | Post-Usage notes and examples in help texts
commandNotes :: Maybe (String -> String),
-- | Initial \/ empty flags
commandDefaultFlags :: flags,
-- | All the Option fields for this command
......@@ -372,32 +378,55 @@ commandListOptions command =
-- | The help text for this command with descriptions of all the options.
commandHelp :: CommandUI flags -> String -> String
commandHelp command pname =
commandUsage command pname
++ (GetOpt.usageInfo ""
. addCommonFlags ShowArgs
$ commandGetOpts ShowArgs command)
++ case commandDescription command of
Nothing -> ""
Just desc -> '\n': desc pname
commandSynopsis command
++ "\n\n"
++ commandUsage command pname
++ ( case commandDescription command of
Nothing -> ""
Just desc -> '\n': desc pname)
++ "\n"
++ ( if cname == ""
then "Global flags:"
else "Flags for " ++ cname ++ ":" )
++ ( GetOpt.usageInfo ""
. addCommonFlags ShowArgs
$ commandGetOpts ShowArgs command )
++ ( case commandNotes command of
Nothing -> ""
Just notes -> '\n': notes pname)
where cname = commandName command
-- | Default "usage" documentation text for commands.
usageDefault :: String -> String -> String
usageDefault name pname =
"Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"
++ "Flags for " ++ name ++ ":"
-- | Create "usage" documentation from a list of parameter
-- configurations.
usageAlternatives :: String -> [String] -> String -> String
usageAlternatives name strs pname = unlines
[ start ++ pname ++ " " ++ name ++ " " ++ s
| let starts = "Usage: " : repeat " or: "
, (start, s) <- zip starts strs
]
-- | Make a Command from standard 'GetOpt' options.
makeCommand :: String -- ^ name
-> String -- ^ short description
-> Maybe (String -> String) -- ^ long description
-> flags -- ^ initial\/empty flags
mkCommandUI :: String -- ^ name
-> String -- ^ synopsis
-> [String] -- ^ usage alternatives
-> flags -- ^ initial\/empty flags
-> (ShowOrParseArgs -> [OptionField flags]) -- ^ options
-> CommandUI flags
makeCommand name shortDesc longDesc defaultFlags options =
CommandUI {
commandName = name,
commandSynopsis = shortDesc,
commandDescription = longDesc,
commandUsage = usage,
commandDefaultFlags = defaultFlags,
commandOptions = options
mkCommandUI name synopsis usages flags options = CommandUI
{ commandName = name
, commandSynopsis = synopsis
, commandDescription = Nothing
, commandNotes = Nothing
, commandUsage = usageAlternatives name usages
, commandDefaultFlags = flags
, commandOptions = options
}
where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"
++ "Flags for " ++ name ++ ":"
-- | Common flags that apply to every command
data CommonFlag = HelpFlag | ListOptionsFlag
......@@ -502,7 +531,7 @@ commandsRun :: CommandUI a
-> [String]
-> CommandParse (a, CommandParse action)
commandsRun globalCommand commands args =
case commandParseArgs globalCommand' True args of
case commandParseArgs globalCommand True args of
CommandHelp help -> CommandHelp help
CommandList opts -> CommandList (opts ++ commandNames)
CommandErrors errs -> CommandErrors errs
......@@ -523,25 +552,6 @@ commandsRun globalCommand commands args =
++ " (try --help)\n"]
commands' = commands ++ [commandAddAction helpCommandUI undefined]
commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ]
globalCommand' = globalCommand {
commandUsage = \pname ->
(case commandUsage globalCommand pname of
"" -> ""
original -> original ++ "\n")
++ "Usage: " ++ pname ++ " COMMAND [FLAGS]\n"
++ " or: " ++ pname ++ " [GLOBAL FLAGS]\n\n"
++ "Global flags:",
commandDescription = Just $ \pname ->
"Commands:\n"
++ unlines [ " " ++ align name ++ " " ++ description
| Command name description _ NormalCommand <- commands' ]
++ case commandDescription globalCommand of
Nothing -> ""
Just desc -> '\n': desc pname
}
where maxlen = maximum
[ length name | Command name _ _ NormalCommand <- commands' ]
align str = str ++ replicate (maxlen - length str) ' '
-- A bit of a hack: support "prog help" as a synonym of "prog --help"
-- furthermore, support "prog help command" as "prog command --help"
......@@ -560,14 +570,7 @@ commandsRun globalCommand commands args =
_ -> CommandHelp globalHelp
_ -> badCommand name
where globalHelp = commandHelp globalCommand'
helpCommandUI =
(makeCommand "help" "Help about commands." Nothing () (const [])) {
commandUsage = \pname ->
"Usage: " ++ pname ++ " help [FLAGS]\n"
++ " or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"
++ "Flags for help:"
}
where globalHelp = commandHelp globalCommand
-- | Utility function, many commands do not accept additional flags. This
-- action fails with a helpful error message if the user supplies any extra.
......@@ -578,3 +581,17 @@ noExtraFlags extraFlags =
die $ "Unrecognised flags: " ++ intercalate ", " extraFlags
--TODO: eliminate this function and turn it into a variant on commandAddAction
-- instead like commandAddActionNoArgs that doesn't supply the [String]
-- | Helper function for creating globalCommand description
getNormalCommandDescriptions :: [Command action] -> [(String, String)]
getNormalCommandDescriptions cmds =
[ (name, description)
| Command name description _ NormalCommand <- cmds ]
helpCommandUI :: CommandUI ()
helpCommandUI = mkCommandUI
"help"
"Help about commands."
["[FLAGS]", "COMMAND [FLAGS]"]
()
(const [])
......@@ -24,7 +24,10 @@ module Distribution.Simple.Compiler (
-- * Haskell implementations
module Distribution.Compiler,
Compiler(..),
showCompilerId, compilerFlavor, compilerVersion,
showCompilerId, showCompilerIdWithAbi,
compilerFlavor, compilerVersion,
compilerCompatVersion,
compilerInfo,
-- * Support for package databases
PackageDB(..),
......@@ -58,13 +61,17 @@ import Control.Monad (liftM)
import Data.Binary (Binary)
import Data.List (nub)
import qualified Data.Map as M (Map, lookup)
import Data.Maybe (catMaybes, isNothing)
import Data.Maybe (catMaybes, isNothing, listToMaybe)
import GHC.Generics (Generic)
import System.Directory (canonicalizePath)
data Compiler = Compiler {
compilerId :: CompilerId,
-- ^ Compiler flavour and version.
compilerAbiTag :: AbiTag,
-- ^ Tag for distinguishing incompatible ABI's on the same architecture/os.
compilerCompat :: [CompilerId],
-- ^ Other implementations that this compiler claims to be compatible with.
compilerLanguages :: [(Language, Flag)],
-- ^ Supported language standards.
compilerExtensions :: [(Extension, Flag)],
......@@ -79,12 +86,32 @@ instance Binary Compiler
showCompilerId :: Compiler -> String
showCompilerId = display . compilerId
showCompilerIdWithAbi :: Compiler -> String
showCompilerIdWithAbi comp =
display (compilerId comp) ++
case compilerAbiTag comp of
NoAbiTag -> []
AbiTag xs -> '-':xs
compilerFlavor :: Compiler -> CompilerFlavor
compilerFlavor = (\(CompilerId f _) -> f) . compilerId
compilerVersion :: Compiler -> Version
compilerVersion = (\(CompilerId _ v) -> v) . compilerId
compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion flavor comp
| compilerFlavor comp == flavor = Just (compilerVersion comp)
| otherwise =
listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ]
compilerInfo :: Compiler -> CompilerInfo
compilerInfo c = CompilerInfo (compilerId c)
(compilerAbiTag c)
(Just . compilerCompat $ c)
(Just . map fst . compilerLanguages $ c)
(Just . map fst . compilerExtensions $ c)
-- ------------------------------------------------------------
-- * Package databases
-- ------------------------------------------------------------
......@@ -220,7 +247,10 @@ packageKeySupported = ghcSupported "Uses package keys"
ghcSupported :: String -> Compiler -> Bool
ghcSupported key comp =
case compilerFlavor comp of
GHC -> case M.lookup key (compilerProperties comp) of
Just "YES" -> True
_ -> False
_ -> False
GHC -> checkProp
GHCJS -> checkProp
_ -> False
where checkProp =
case M.lookup key (compilerProperties comp) of
Just "YES" -> True
_ -> False
This diff is collapsed.
This diff is collapsed.