Commit f0d8aca8 authored by Alexis Williams's avatar Alexis Williams

Add --package flag, associated support to new-repl

parent ff32a4ea
......@@ -30,8 +30,8 @@ module Distribution.Compat.Lens (
toListOf,
toSetOf,
-- * Traversal
filtered,
traversed,
filtered,
-- * Lens
cloneLens,
aview,
......@@ -134,6 +134,7 @@ traversed :: Traversable f => Traversal (f a) (f b) a b
traversed = traverse
{-# INLINE [0] traversed #-}
-------------------------------------------------------------------------------
-- Lens
-------------------------------------------------------------------------------
......
......@@ -59,6 +59,11 @@ instance Functor Flag where
fmap f (Flag x) = Flag (f x)
fmap _ NoFlag = NoFlag
instance Applicative Flag where
(Flag x) <*> y = x <$> y
NoFlag <*> _ = NoFlag
pure = Flag
instance Monoid (Flag a) where
mempty = NoFlag
mappend = (<>)
......
......@@ -117,6 +117,7 @@ module Distribution.Simple.Utils (
TempFileOptions(..), defaultTempFileOptions,
withTempFile, withTempFileEx,
withTempDirectory, withTempDirectoryEx,
createTempDirectory,
-- * .cabal and .buildinfo files
defaultPackageDesc,
......
......@@ -7,6 +7,7 @@ import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Types.BuildInfo (BuildInfo)
import Distribution.Types.Executable (Executable)
import Distribution.Types.ExecutableScope (ExecutableScope)
import Distribution.Types.UnqualComponentName (UnqualComponentName)
......@@ -25,8 +26,6 @@ exeScope :: Lens' Executable ExecutableScope
exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s))
{-# INLINE exeScope #-}
{-
buildInfo :: Lens' Executable BuildInfo
buildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s))
{-# INLINE buildInfo #-}
-}
exeBuildInfo :: Lens' Executable BuildInfo
exeBuildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s))
{-# INLINE exeBuildInfo #-}
......@@ -13,9 +13,12 @@ import Distribution.Version
( Version, nullVersion )
import qualified Distribution.Compat.ReadP as Parse
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
import Distribution.Compat.ReadP
import Distribution.Text
import Distribution.Parsec.Class
( Parsec(..) )
import Distribution.Pretty
import Distribution.Types.PackageName
......@@ -43,5 +46,9 @@ instance Text PackageIdentifier where
v <- (Parse.char '-' >> parse) <++ return nullVersion
return (PackageIdentifier n v)
instance Parsec PackageIdentifier where
parsec = PackageIdentifier <$>
parsec <*> (P.char '-' *> parsec <|> pure nullVersion)
instance NFData PackageIdentifier where
rnf (PackageIdentifier name version) = rnf name `seq` rnf version
......@@ -14,7 +14,8 @@ module Distribution.Client.CmdInstall (
-- * Internals exposed for testing
TargetProblem(..),
selectPackageTargets,
selectComponentTarget
selectComponentTarget,
establishDummyProjectBaseContext
) where
import Prelude ()
......
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
-- | cabal-install CLI command: repl
--
......@@ -13,34 +17,134 @@ module Distribution.Client.CmdRepl (
selectComponentTarget
) where
import Distribution.Client.ProjectPlanning (ElaboratedSharedConfig(..))
import Distribution.Client.ProjectPlanning
( ElaboratedSharedConfig(..) )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
import Distribution.Compat.Lens
import qualified Distribution.Types.Lens as L
import Distribution.Client.CmdInstall
( establishDummyProjectBaseContext )
import Distribution.Client.IndexUtils
( getSourcePackages )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.ProjectConfig
( ProjectConfig(..), BadPackageLocations(..), BadPackageLocation(..)
, ProjectConfigProvenance(..), projectConfigWithBuilderRepoContext )
import Distribution.Client.Setup
( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
import qualified Distribution.Client.Setup as Client
import Distribution.Client.TargetSelector
( TargetSelector(..), TargetImplicitCwd(..), ComponentKind(..) )
import Distribution.Client.Types
( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage
, SourcePackageDb(..) )
import Distribution.Simple.Setup
( HaddockFlags, fromFlagOrDefault, replOptions )
( HaddockFlags, fromFlagOrDefault, replOptions
, Flag(..), toFlag, trueArg, falseArg )
import Distribution.Simple.Command
( CommandUI(..), liftOption, usageAlternatives )
( CommandUI(..), liftOption, usageAlternatives, option
, ShowOrParseArgs, OptionField, reqArg )
import Distribution.Package
( packageName )
( Package(..), packageName )
import Distribution.PackageDescription.PrettyPrint
import Distribution.Parsec.Class
( Parsec(..) )
import Distribution.Pretty
( prettyShow )
import Distribution.ReadE
( ReadE, parsecToReadE )
import qualified Distribution.SPDX.License as SPDX
import Distribution.Solver.Types.SourcePackage
( SourcePackage(..) )
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import Distribution.Types.BuildInfo
( BuildInfo(..), emptyBuildInfo )
import Distribution.Types.ComponentName
( componentNameString )
( ComponentName(..), componentNameString )
import Distribution.Types.CondTree
( CondTree(..) )
import Distribution.Types.Dependency
( Dependency(..), thisPackageVersion )
import Distribution.Types.GenericPackageDescription
( emptyGenericPackageDescription )
import Distribution.Types.PackageDescription
( PackageDescription(..), emptyPackageDescription )
import Distribution.Types.Library
( Library(..), emptyLibrary )
import Distribution.Types.PackageId
( PackageIdentifier(..), PackageId )
import Distribution.Types.UnqualComponentName
( UnqualComponentName )
import Distribution.Types.Version
( mkVersion, version0, nullVersion )
import Distribution.Types.VersionRange
( anyVersion )
import Distribution.Text
( display )
import Distribution.Verbosity
( Verbosity, normal )
( Verbosity, normal, lessVerbose )
import Distribution.Simple.Utils
( wrapText, die', ordNub )
( wrapText, die', ordNub, createTempDirectory, handleDoesNotExist )
import Language.Haskell.Extension
( Language(..) )
import Control.Exception
( catch, throwIO )
import Control.Monad
( when, unless )
import Data.List
( sortOn )
import qualified Data.Map as Map
import Data.Ord
( Down(..) )
import qualified Data.Set as Set
import Control.Monad (when)
replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, [String])
import System.Directory
( getTemporaryDirectory, removeDirectoryRecursive )
import System.FilePath
( (</>) )
type ReplFlags = [String]
data EnvFlags = EnvFlags
{ envPackages :: [PackageId]
, envIncludeTransitive :: Flag Bool
, envOnlySpecified :: Flag Bool
}
defaultEnvFlags :: EnvFlags
defaultEnvFlags = EnvFlags
{ envPackages = []
, envIncludeTransitive = toFlag True
, envOnlySpecified = toFlag False
}
envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
envOptions _ =
[ option ['p'] ["package"]
"Include an additional package in the environment presented to GHCi."
envPackages (\p flags -> flags { envPackages = p ++ envPackages flags })
(reqArg "PACKAGE" packageIdReadE (fmap prettyShow :: [PackageId] -> [String]))
, option [] ["no-transitive-deps"]
"Don't automatically include transitive dependencies of requested packages."
envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p })
falseArg
, option ['z'] ["only-specified"]
"Only include explicitly specified packages (and 'base'). This implies '--no-transitive-deps'."
envOnlySpecified (\p flags -> flags { envOnlySpecified = p, envIncludeTransitive = not <$> p})
trueArg
]
where
packageIdReadE :: ReadE [PackageId]
packageIdReadE =
fmap pure $
parsecToReadE
("couldn't parse package ID: " ++)
parsec
replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, ReplFlags, EnvFlags)
replCommand = Client.installCommand {
commandName = "new-repl",
commandSynopsis = "Open an interactive session for the given component.",
......@@ -70,24 +174,32 @@ replCommand = Client.installCommand {
++ " for the component named 'cname'\n"
++ " " ++ pname ++ " new-repl pkgname:cname\n"
++ " for the component 'cname' in the package 'pkgname'\n\n"
++ " " ++ pname ++ " new-repl --package lens\n"
++ " add the package 'lens' to the default component (or no component "
++ "if there is no package present)\n"
++ cmdCommonHelpTextNewBuildBeta,
commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,[]),
commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,[],defaultEnvFlags),
commandOptions = \showOrParseArgs ->
map liftOriginal (commandOptions Client.installCommand showOrParseArgs)
++ map liftReplOpts (replOptions showOrParseArgs)
++ map liftEnvOpts (envOptions showOrParseArgs)
}
where
(configFlags,configExFlags,installFlags,haddockFlags) = commandDefaultFlags Client.installCommand
liftOriginal = liftOption projectOriginal updateOriginal
liftReplOpts = liftOption projectReplOpts updateReplOpts
liftEnvOpts = liftOption projectEnvOpts updateEnvOpts
projectOriginal (a,b,c,d,_,_) = (a,b,c,d)
updateOriginal (a,b,c,d) (_,_,_,_,e,f) = (a,b,c,d,e,f)
projectOriginal (a,b,c,d,_) = (a,b,c,d)
updateOriginal (a,b,c,d) (_,_,_,_,x) = (a,b,c,d,x)
projectReplOpts (_,_,_,_,e,_) = e
updateReplOpts e (a,b,c,d,_,f) = (a,b,c,d,e,f)
projectReplOpts (_,_,_,_,x) = x
updateReplOpts v (a,b,c,d,_) = (a,b,c,d,v)
projectEnvOpts (_,_,_,_,_,f) = f
updateEnvOpts f (a,b,c,d,e,_) = (a,b,c,d,e,f)
-- | The @repl@ command is very much like @build@. It brings the install plan
-- up to date, selects that part of the plan needed by the given or implicit
......@@ -100,62 +212,223 @@ replCommand = Client.installCommand {
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, [String])
replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, ReplFlags, EnvFlags)
-> [String] -> GlobalFlags -> IO ()
replAction (configFlags, configExFlags, installFlags, haddockFlags, replArgs)
replAction (configFlags, configExFlags, installFlags, haddockFlags, replFlags, envFlags)
targetStrings globalFlags = do
baseCtx <- establishProjectBaseContext verbosity cliConfig
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings
buildCtx' <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
when (buildSettingOnlyDeps (buildSettings baseCtx)) $
die' verbosity $ "The repl command does not support '--only-dependencies'. "
++ "You may wish to use 'build --only-dependencies' and then "
++ "use 'repl'."
-- Interpret the targets on the command line as repl targets
-- (as opposed to say build or haddock targets).
targets <- either (reportTargetProblems verbosity) return
$ resolveTargets
selectPackageTargets
selectComponentTarget
TargetProblemCommon
elaboratedPlan
Nothing
targetSelectors
-- Reject multiple targets, or at least targets in different
-- components. It is ok to have two module/file targets in the
-- same component, but not two that live in different components.
when (Set.size (distinctTargetComponents targets) > 1) $
reportTargetProblems verbosity
[TargetProblemMultipleTargets targets]
let elaboratedPlan' = pruneInstallPlanToTargets
TargetActionRepl
targets
elaboratedPlan
return (elaboratedPlan', targets)
let
onlySpecified = fromFlagOrDefault False (envOnlySpecified envFlags)
with = withProject cliConfig verbosity targetStrings
without = withoutProject cliConfig verbosity targetStrings
(baseCtx, targetSelectors, finalizer) <-
if onlySpecified
then
without
else
catch with
$ \case
(BadPackageLocations prov locs)
| prov == Set.singleton Implicit
, let
isGlobErr (BadLocGlobEmptyMatch _) = True
isGlobErr _ = False
, any isGlobErr locs ->
without
err -> throwIO err
when (buildSettingOnlyDeps (buildSettings baseCtx)) $
die' verbosity $ "The repl command does not support '--only-dependencies'. "
++ "You may wish to use 'build --only-dependencies' and then "
++ "use 'repl'."
baseCtx' <- if null (envPackages envFlags)
then return baseCtx
else
-- Unfortunately, the best way to do this is to let the normal solver
-- help us resolve the targets, but that isn't ideal for performance,
-- especially in the no-project case.
withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan -> do
-- Interpret the targets on the command line as repl targets
-- (as opposed to say build or haddock targets).
targets <- either (reportTargetProblems verbosity) return
$ resolveTargets
selectPackageTargets
selectComponentTarget
TargetProblemCommon
elaboratedPlan
Nothing
targetSelectors
-- Reject multiple targets, or at least targets in different
-- components. It is ok to have two module/file targets in the
-- same component, but not two that live in different components.
when (Set.size (distinctTargetComponents targets) > 1) $
reportTargetProblems verbosity
[TargetProblemMultipleTargets targets]
let
(unitId, ((ComponentTarget cname _, _):_)) = head $ Map.toList targets
Just pkgId = packageId <$> InstallPlan.lookup elaboratedPlan unitId
deps = pkgIdToDependency <$> envPackages envFlags
return $ addDepsToProjectTarget deps pkgId cname baseCtx
-- Now, we run the solver again with the added packages. While the graph
-- won't actually reflect the addition of transitive dependencies,
-- they're going to be available already and will be offered to the REPL
-- and that's good enough.
buildCtx' <- runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do
-- Recalculate with updated project.
targets <- either (reportTargetProblems verbosity) return
$ resolveTargets
selectPackageTargets
selectComponentTarget
TargetProblemCommon
elaboratedPlan
Nothing
targetSelectors
when (Set.size (distinctTargetComponents targets) > 1) $
reportTargetProblems verbosity
[TargetProblemMultipleTargets targets]
let elaboratedPlan' = pruneInstallPlanToTargets
TargetActionRepl
targets
elaboratedPlan
return (elaboratedPlan', targets)
let buildCtx = buildCtx'
{ elaboratedShared = (elaboratedShared buildCtx')
{ pkgConfigReplOptions = replArgs }
{ pkgConfigReplOptions = replFlags }
}
printPlan verbosity baseCtx buildCtx
buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
finalizer
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags
installFlags haddockFlags
withProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ())
withProject cliConfig verbosity targetStrings = do
baseCtx <- establishProjectBaseContext verbosity cliConfig
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings
return (baseCtx, targetSelectors, return ())
withoutProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ())
withoutProject config verbosity extraArgs = do
unless (null extraArgs) $
die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs
globalTmp <- getTemporaryDirectory
tempDir <- createTempDirectory globalTmp "cabal-repl."
baseCtx <- establishDummyProjectBaseContext
verbosity
config
tempDir
[]
pkgDb <- projectConfigWithBuilderRepoContext
verbosity
(buildSettings baseCtx)
(getSourcePackages verbosity)
-- We need to create a dummy package that lives in our dummy project.
let
(basePkg:_) = sortOn (Down . packageId) $
PackageIndex.lookupPackageName (packageIndex pkgDb) "base"
sourcePackage = SourcePackage
{ packageInfoId = pkgId
, packageDescription = genericPackageDescription
, packageSource = LocalUnpackedPackage tempDir
, packageDescrOverride = Nothing
}
genericPackageDescription = emptyGenericPackageDescription
& L.packageDescription .~ packageDescription
& L.condLibrary .~ Just (CondNode library [] [])
packageDescription = emptyPackageDescription
{ package = pkgId
, specVersionRaw = Left (mkVersion [2, 2])
, library = Just library
, licenseRaw = Left SPDX.NONE
}
library = emptyLibrary { libBuildInfo = buildInfo }
buildInfo = emptyBuildInfo
{ targetBuildDepends = [pkgIdToDependency (packageId basePkg)]
, defaultLanguage = Just Haskell2010
}
pkgId = PackageIdentifier "fake-package" version0
putStrLn $ showGenericPackageDescription genericPackageDescription
writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription
baseCtx' <- establishDummyProjectBaseContext
verbosity
config
tempDir
[SpecificSourcePackage sourcePackage]
let
targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]
finalizer = return () --handleDoesNotExist () (removeDirectoryRecursive tempDir)
return (baseCtx', targetSelectors, finalizer)
addDepsToProjectTarget :: [Dependency]
-> PackageId
-> ComponentName
-> ProjectBaseContext
-> ProjectBaseContext
addDepsToProjectTarget deps pkgId cname ctx =
(\p -> ctx { localPackages = p }) . fmap (fmap go) . localPackages $ ctx
where
go :: UnresolvedSourcePackage -> UnresolvedSourcePackage
go pkg
| packageId pkg /= pkgId = pkg
| SourcePackage{..} <- pkg =
pkg { packageDescription =
packageDescription & L.packageDescription . buildInfoL cname . L.targetBuildDepends %~ (deps ++)
}
pkgIdToDependency :: PackageId -> Dependency
pkgIdToDependency pkgId
| PackageIdentifier{..} <- pkgId
, pkgVersion == nullVersion = Dependency pkgName anyVersion
| otherwise = thisPackageVersion pkgId
buildInfoL :: ComponentName -> Traversal' PackageDescription BuildInfo
buildInfoL cname = case cname of
CLibName -> L.library . traversed . L.libBuildInfo
CSubLibName name ->
buildInfoL' name L.subLibraries (L.libName . non "") L.libBuildInfo
CFLibName name ->
buildInfoL' name L.foreignLibs L.foreignLibName L.foreignLibBuildInfo
CExeName name ->
buildInfoL' name L.executables L.exeName L.exeBuildInfo
CTestName name ->
buildInfoL' name L.testSuites L.testName L.testBuildInfo
CBenchName name ->
buildInfoL' name L.benchmarks L.benchmarkName L.benchmarkBuildInfo
where
buildInfoL' :: UnqualComponentName
-> Traversal' PackageDescription [a]
-> Traversal' a UnqualComponentName
-> Traversal' a BuildInfo
-> Traversal' PackageDescription BuildInfo
buildInfoL' name pdL nameL biL =
pdL
. traversed
. filtered ((== name) . view nameL)
. biL
-- | This defines what a 'TargetSelector' means for the @repl@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
......
......@@ -82,6 +82,7 @@ isFetched loc = case loc of
RemoteTarballPackage _uri local -> return (isJust local)
RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)
RemoteSourceRepoPackage _ local -> return (isJust local)
-- | Checks if the package has already been fetched (or does not need
-- fetching) and if so returns evidence in the form of a 'PackageLocation'
......@@ -107,7 +108,6 @@ checkFetched loc = case loc of
fmap (fmap (RepoTarballPackage repo pkgid))
(checkRepoTarballFetched repo pkgid)
-- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.
--
checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)
......
......@@ -1300,7 +1300,6 @@ installLocalPackage verbosity pkgid location distPref installPkg =
installLocalTarballPackage verbosity
pkgid tarballPath distPref installPkg
installLocalTarballPackage
:: Verbosity
-> PackageIdentifier -> FilePath -> FilePath
......
......@@ -236,7 +236,7 @@ data PackageSpecifier pkg =
-- | A fully specified source package.
--
| SpecificSourcePackage pkg
deriving (Eq, Show, Generic)
deriving (Eq, Show, Functor, Generic)
instance Binary pkg => Binary (PackageSpecifier pkg)
......@@ -286,7 +286,6 @@ data PackageLocation local =
-- | A package available from a version control system source repository
| RemoteSourceRepoPackage SourceRepo local
deriving (Show, Functor, Eq, Ord, Generic, Typeable)
instance Binary local => Binary (PackageLocation local)
......
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