Skip to content

GitLab

C
Cabal
Commit d091534e authored by Alexis Williams's avatar Alexis Williams
Browse files
Options

Add library component installation support

parent 06d1c93a
Hide whitespace changes
Inline Side-by-side
Showing with 188 additions and 19 deletions
Cabal/Distribution/Simple/GHC.hs
View file @ d091534e
......@@ -56,7 +56,9 @@ module Distribution.Simple.GHC (
-- * Constructing GHC environment files
Internal.GhcEnvironmentFileEntry(..),
Internal.simpleGhcEnvironmentFile,
Internal.renderGhcEnvironmentFile,
Internal.writeGhcEnvironmentFile,
Internal.ghcPlatformAndVersionString,
-- * Version-specific implementation quirks
getImplInfo,
GhcImplInfo(..)
......
Cabal/Distribution/Simple/GHC/Internal.hs
View file @ d091534e
......@@ -549,6 +549,7 @@ data GhcEnvironmentFileEntry =
-- @user-package-db@ or
-- @package-db blah/package.conf.d/@
| GhcEnvFileClearPackageDbStack -- ^ @clear-package-db@
deriving (Eq, Show)
-- | Make entries for a GHC environment file based on a 'PackageDBStack' and
-- a bunch of package (unit) ids.
......
cabal-install/Distribution/Client/CmdInstall.hs
View file @ d091534e
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
......@@ -22,23 +23,28 @@ import Distribution.Client.Compat.Prelude
import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
import Distribution.Client.CmdSdist
import Distribution.Client.CmdInstall.EnvironmentParser
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
import Distribution.Client.Types
( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage )
import Distribution.Client.ProjectPlanning.Types
( pkgConfigCompiler )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Package
( Package(..), mkPackageName )
import Distribution.Types.PackageId
( PackageIdentifier(..) )
import Distribution.Client.ProjectConfig.Types
( ProjectConfig, ProjectConfigBuildOnly(..)
( ProjectConfig(..), ProjectConfigShared(..), ProjectConfigBuildOnly(..)
, PackageConfig(..), getMapLast, getMapMappend
, projectConfigLogsDir, projectConfigStoreDir, projectConfigShared
, projectConfigBuildOnly, projectConfigDistDir
, projectConfigProjectFile, projectConfigConfigFile )
import Distribution.Simple.Program.Db
( userSpecifyPaths, userSpecifyArgss, defaultProgramDb
, modifyProgramSearchPath )
import Distribution.Simple.Program.Find
( ProgramSearchPathEntry(..) )
import Distribution.Client.Config
( getCabalDir )
import Distribution.Client.IndexUtils
......@@ -62,8 +68,14 @@ import Distribution.Solver.Types.SourcePackage
( SourcePackage(..) )
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives )
import Distribution.Simple.Configure
( configCompilerEx )
import Distribution.Simple.Compiler
( compilerId )
( Compiler(..), CompilerId(..), CompilerFlavor(..) )
import Distribution.Simple.GHC
( ghcPlatformAndVersionString
, GhcImplInfo(..), getImplInfo
, GhcEnvironmentFileEntry(..), renderGhcEnvironmentFile )
import Distribution.Types.UnitId
( UnitId )
import Distribution.Types.UnqualComponentName
......@@ -73,13 +85,22 @@ import Distribution.Verbosity
import Distribution.Simple.Utils
( wrapText, die', notice
, withTempDirectory, createDirectoryIfMissingVerbose )
import Control.Exception ( catch, throwIO )
import Data.Either ( partitionEithers )
import Distribution.Utils.Generic
( writeFileAtomic )
import Control.Exception
( catch, throwIO )
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Either
( partitionEithers )
import qualified Data.Map as Map
import Distribution.Utils.NubList
( fromNubList )
import qualified Data.Set as Set
import System.Directory ( getTemporaryDirectory, makeAbsolute )
import System.FilePath ( (</>) )
import System.Directory
( getHomeDirectory, doesFileExist, createDirectoryIfMissing
, getTemporaryDirectory, makeAbsolute )
import System.FilePath ( (</>), takeDirectory )
import qualified Distribution.Client.CmdBuild as CmdBuild
......@@ -166,7 +187,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
sdistAction sdistFlags ["all"] globalFlags
withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan -> do
(specs, selectors) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan -> do
-- Split into known targets and hackage packages.
(targets, hackageNames) <- case
resolveTargets
......@@ -235,16 +256,20 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
if null targets
then return (hackagePkgs, hackageTargets)
else return (local ++ hackagePkgs, targets' ++ hackageTargets)
return (specs, selectors, projectConfig localBaseCtx)
withoutProject = do
let
packageNames = mkPackageName <$> targetStrings
packageSpecifiers = flip NamedPackage [] <$> packageNames
targetSelectors = flip TargetPackageNamed Nothing <$> packageNames
return (packageSpecifiers, targetSelectors)
(specs, selectors) <- catch withProject
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
return (packageSpecifiers, targetSelectors, globalConfig <> cliConfig)
(specs, selectors, config) <- catch withProject
$ \case
(BadPackageLocations prov locs)
| prov == Set.singleton Implicit
......@@ -253,7 +278,51 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
isGlobErr _ = False
, any isGlobErr locs ->
withoutProject
err -> throwIO err
err -> throwIO err
home <- getHomeDirectory
let
ProjectConfig {
projectConfigShared = ProjectConfigShared {
projectConfigHcFlavor,
projectConfigHcPath,
projectConfigHcPkg
},
projectConfigLocalPackages = PackageConfig {
packageConfigProgramPaths,
packageConfigProgramArgs,
packageConfigProgramPathExtra
}
} = config
hcFlavor = flagToMaybe projectConfigHcFlavor
hcPath = flagToMaybe projectConfigHcPath
hcPkg = flagToMaybe projectConfigHcPkg
progDb =
userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
. userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))
. modifyProgramSearchPath
(++ [ ProgramSearchPathDir dir
| dir <- fromNubList packageConfigProgramPathExtra ])
$ defaultProgramDb
(compiler@Compiler { compilerId = CompilerId compilerFlavor compilerVersion }, platform, _) <-
configCompilerEx hcFlavor hcPath hcPkg progDb verbosity
let
envFile = home </> ".ghc" </> ghcPlatformAndVersionString platform compilerVersion
</> "environments" </> "default"
GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler
envFileExists <- doesFileExist envFile
envEntries <- if
| compilerFlavor == GHC || compilerFlavor == GHCJS
, supportsPkgEnvFiles
, envFileExists -> readEnvironmentFile envFile
| otherwise -> return []
let envSpecs = environmentFileToSpecifiers envEntries
-- Second, we need to use a fake project to let Cabal build the
-- installables correctly. For that, we need a place to put a
......@@ -266,9 +335,9 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
$ \tmpDir -> do
baseCtx <- establishDummyProjectBaseContext
verbosity
cliConfig
config
tmpDir
specs
(envSpecs ++ specs)
buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
......@@ -300,7 +369,14 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
let compiler = pkgConfigCompiler $ elaboratedShared buildCtx
let entries = entriesForLibraryComponents (targetsMap buildCtx)
createDirectoryIfMissing True (takeDirectory envFile)
when supportsPkgEnvFiles $ do
let
entries' = nub (envEntries ++ entries)
contents' = renderGhcEnvironmentFile entries'
writeFileAtomic envFile (BS.pack contents')
let mkPkgBinDir = (</> "bin") .
storePackageDirectory
(cabalStoreDirLayout $ cabalDirLayout baseCtx)
......@@ -358,6 +434,20 @@ symlinkBuiltExe verbosity sourceDir destDir exe = do
exe
$ unUnqualComponentName exe
-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []
where
hasLib :: (ComponentTarget, [TargetSelector]) -> Bool
hasLib (ComponentTarget CLibName _, _) = True
hasLib (ComponentTarget (CSubLibName _) _, _) = True
hasLib _ = False
go :: UnitId -> [(ComponentTarget, [TargetSelector])] -> [GhcEnvironmentFileEntry]
go unitId targets
| any hasLib targets = [GhcEnvFilePackageId unitId]
| otherwise = []
-- | Create a dummy project context, without a .cabal or a .cabal.project file
-- (a place where to put a temporary dist directory is still needed)
establishDummyProjectBaseContext
......
cabal-install/Distribution/Client/CmdInstall/EnvironmentParser.hs 0 → 100644
View file @ d091534e
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.CmdInstall.EnvironmentParser
( readEnvironmentFile, ParseErrorExc(..)
, environmentFileToSpecifiers
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Client.Types
( PackageSpecifier(..) )
import Distribution.Simple.Compiler
( PackageDB(..) )
import Distribution.Simple.GHC
( GhcEnvironmentFileEntry(..) )
import Distribution.Solver.Types.PackageConstraint
( PackageProperty(..) )
import Distribution.Types.PackageId
( PackageIdentifier(..) )
import Distribution.Types.UnitId
( mkUnitId, unUnitId )
import Distribution.Types.VersionRange
( thisVersion )
import Control.Exception
( Exception, throwIO )
import Data.Char
( isAlphaNum )
import Data.Typeable
( Typeable )
import Distribution.Text
( simpleParse )
import qualified Text.Parsec as P
import Text.Parsec.String
( Parser, parseFromFile )
parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry
parseEnvironmentFileLine = GhcEnvFileComment <$> comment
<|> GhcEnvFilePackageId <$> unitId
<|> GhcEnvFilePackageDb <$> packageDb
<|> pure GhcEnvFileClearPackageDbStack <* clearDb
where
comment = P.string "--" *> P.many (P.noneOf "\r\n")
unitId = P.string "package-id" *> P.spaces *>
(mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+"))
packageDb = (P.string "global-package-db" *> pure GlobalPackageDB)
<|> (P.string "user-package-db" *> pure UserPackageDB)
<|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.anyChar `P.endBy` P.endOfLine))
clearDb = P.string "clear-package-db"
newtype ParseErrorExc = ParseErrorExc P.ParseError
deriving (Show, Typeable)
instance Exception ParseErrorExc
parseEnvironmentFile :: Parser [GhcEnvironmentFileEntry]
parseEnvironmentFile = parseEnvironmentFileLine `P.endBy` P.endOfLine
readEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry]
readEnvironmentFile path =
either (throwIO . ParseErrorExc) return =<<
parseFromFile parseEnvironmentFile path
environmentFileToSpecifiers :: [GhcEnvironmentFileEntry] -> [PackageSpecifier a]
environmentFileToSpecifiers = foldMap $ \case
(GhcEnvFilePackageId unitId)
| Just PackageIdentifier{..} <- simpleParse (unUnitId unitId) ->
[ NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] ]
_ -> []
cabal-install/cabal-install.cabal
View file @ d091534e
......@@ -155,6 +155,7 @@ library
Distribution.Client.CmdFreeze
Distribution.Client.CmdHaddock
Distribution.Client.CmdInstall
Distribution.Client.CmdInstall.EnvironmentParser
Distribution.Client.CmdRepl
Distribution.Client.CmdRun
Distribution.Client.CmdTest
......@@ -320,6 +321,7 @@ library
zlib >= 0.5.3 && < 0.7,
hackage-security >= 0.5.2.2 && < 0.6,
text >= 1.2.3 && < 1.3,
parsec >= 3.1.13.0 && < 3.2,
zip-archive >= 0.3.2.5 && < 0.4
if flag(native-dns)
......@@ -399,6 +401,7 @@ executable cabal
zlib >= 0.5.3 && < 0.7,
hackage-security >= 0.5.2.2 && < 0.6,
text >= 1.2.3 && < 1.3,
parsec >= 3.1.13.0 && < 3.2,
zip-archive >= 0.3.2.5 && < 0.4
other-modules:
......@@ -416,6 +419,7 @@ executable cabal
Distribution.Client.CmdFreeze
Distribution.Client.CmdHaddock
Distribution.Client.CmdInstall
Distribution.Client.CmdInstall.EnvironmentParser
Distribution.Client.CmdLegacy
Distribution.Client.CmdRepl
Distribution.Client.CmdRun
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment