Commit 6a545fa7 authored by Alexis Williams's avatar Alexis Williams

Final clean-up before merge

parent 72903686
......@@ -64,9 +64,7 @@ import Distribution.Client.IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.ProjectConfig
( readGlobalConfig, projectConfigWithBuilderRepoContext
, resolveBuildTimeSettings
, BadPackageLocations(..), BadPackageLocation(..)
, ProjectConfigProvenance(..) )
, resolveBuildTimeSettings, withProjectOrGlobalConfig )
import Distribution.Client.DistDirLayout
( defaultDistDirLayout, DistDirLayout(..), mkCabalDirLayout
, ProjectRoot(ProjectRootImplicit)
......@@ -111,7 +109,7 @@ import Distribution.Text
( simpleParse )
import Control.Exception
( catch, throwIO )
( catch )
import Control.Monad
( mapM, mapM_ )
import qualified Data.ByteString.Lazy.Char8 as BS
......@@ -120,7 +118,6 @@ import Data.Either
import Data.Ord
( comparing, Down(..) )
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Utils.NubList
( fromNubList )
import System.Directory
......@@ -352,7 +349,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstal
return (specs ++ packageSpecifiers, selectors ++ packageTargets, projectConfig localBaseCtx)
withoutProject = do
withoutProject globalConfig = do
let
parsePkg pkgName
| Just (pkg :: PackageId) <- simpleParse pkgName = return pkg
......@@ -365,21 +362,10 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstal
| otherwise ->
NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)]
packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
return (packageSpecifiers, packageTargets, globalConfig <> cliConfig)
(specs, selectors, config) <- catch withProject
$ \case
(BadPackageLocations prov locs)
| prov == Set.singleton Implicit
, let
isGlobErr (BadLocGlobEmptyMatch _) = True
isGlobErr _ = False
, any isGlobErr locs ->
withoutProject
err -> throwIO err
(specs, selectors, config) <- withProjectOrGlobalConfig verbosity globalConfigFlag
withProject withoutProject
home <- getHomeDirectory
let
......@@ -560,6 +546,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstal
cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags' configExFlags
installFlags haddockFlags
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
globalPackages :: [PackageName]
globalPackages = mkPackageName <$>
......
......@@ -30,8 +30,7 @@ import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.ProjectBuilding
( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages )
import Distribution.Client.ProjectConfig
( ProjectConfig(..), BadPackageLocations(..), BadPackageLocation(..)
, ProjectConfigProvenance(..)
( ProjectConfig(..), withProjectOrGlobalConfig
, projectConfigConfigFile, readGlobalConfig )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
......@@ -41,8 +40,6 @@ import Distribution.Client.RebuildMonad
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 )
import Distribution.Simple.Setup
......@@ -78,7 +75,7 @@ import Distribution.Types.PackageDescription
import Distribution.Types.Library
( Library(..), emptyLibrary )
import Distribution.Types.PackageId
( PackageIdentifier(..), PackageId )
( PackageIdentifier(..) )
import Distribution.Types.Version
( mkVersion, version0 )
import Distribution.Types.VersionRange
......@@ -92,10 +89,6 @@ import Distribution.Simple.Utils
import Language.Haskell.Extension
( Language(..) )
import Control.Exception
( catch, throwIO )
import Control.Monad
( when, unless )
import Data.List
( (\\) )
import qualified Data.Map as Map
......@@ -110,14 +103,14 @@ type ReplFlags = [String]
data EnvFlags = EnvFlags
{ envPackages :: [Dependency]
, envIncludeTransitive :: Flag Bool
, envOnlySpecified :: Flag Bool
, envIgnoreProject :: Flag Bool
}
defaultEnvFlags :: EnvFlags
defaultEnvFlags = EnvFlags
{ envPackages = []
, envIncludeTransitive = toFlag True
, envOnlySpecified = toFlag False
, envIgnoreProject = toFlag False
}
envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
......@@ -131,8 +124,8 @@ envOptions _ =
envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p })
falseArg
, option ['z'] ["ignore-project"]
"Only include explicitly specified packages (and 'base'). This implies '--no-transitive-deps'."
envOnlySpecified (\p flags -> flags { envOnlySpecified = p, envIncludeTransitive = not <$> p})
"Only include explicitly specified packages (and 'base')."
envIgnoreProject (\p flags -> flags { envIgnoreProject = p })
trueArg
]
where
......@@ -173,9 +166,12 @@ 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"
++ " " ++ pname ++ " new-repl --build-depends lens\n"
++ " add the latest version of the library 'lens' to the default component "
++ "(or no componentif there is no project present)\n"
++ " " ++ pname ++ " new-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"
++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' "
++ "to the default component (or no component if there is no project present)\n"
++ cmdCommonHelpTextNewBuildBeta,
commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,[],defaultEnvFlags),
......@@ -216,25 +212,15 @@ replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, ReplFlags
replAction (configFlags, configExFlags, installFlags, haddockFlags, replFlags, envFlags)
targetStrings globalFlags = do
let
onlySpecified = fromFlagOrDefault False (envOnlySpecified envFlags)
with = withProject cliConfig verbosity targetStrings
without = withoutProject cliConfig verbosity targetStrings
ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags)
with = withProject cliConfig verbosity targetStrings
without config = withoutProject (config <> 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
(baseCtx, targetSelectors, finalizer) <- if ignoreProject
then do
globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
without globalConfig
else withProjectOrGlobalConfig verbosity globalConfigFlag with without
when (buildSettingOnlyDeps (buildSettings baseCtx)) $
die' verbosity $ "The repl command does not support '--only-dependencies'. "
......@@ -281,9 +267,8 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags, replFlags, e
elaboratedPlan
includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags)
replFlags' = case originalComponent of
Just oci
| includeTransitive -> generateTransitiveReplFlags elaboratedPlan' oci
_ -> []
Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci
Nothing -> []
pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared'
elaboratedPlan'
......@@ -316,6 +301,7 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags, replFlags, e
cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags
installFlags haddockFlags
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
validatedTargets elaboratedPlan targetSelectors = do
-- Interpret the targets on the command line as repl targets
......@@ -354,7 +340,7 @@ withProject cliConfig verbosity targetStrings = do
return (baseCtx, targetSelectors, return ())
withoutProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ())
withoutProject cliConfig verbosity extraArgs = do
withoutProject config verbosity extraArgs = do
unless (null extraArgs) $
die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs
......@@ -387,14 +373,11 @@ withoutProject cliConfig verbosity extraArgs = do
putStrLn $ showGenericPackageDescription genericPackageDescription
writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription
let globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
baseCtx <-
establishDummyProjectBaseContext
verbosity
(globalConfig <> cliConfig)
config
tempDir
[SpecificSourcePackage sourcePackage]
......@@ -422,8 +405,8 @@ addDepsToProjectTarget deps pkgId ctx =
}
addDeps spec = spec
generateTransitiveReplFlags :: ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags
generateTransitiveReplFlags elaboratedPlan OriginalComponentInfo{..} = flags
generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags
generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags
where
deps, deps', trans, trans' :: [UnitId]
flags :: ReplFlags
......@@ -431,7 +414,8 @@ generateTransitiveReplFlags elaboratedPlan OriginalComponentInfo{..} = flags
deps' = deps \\ ociOriginalDeps
trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'
trans' = trans \\ ociOriginalDeps
flags = ("-package-id " ++) . prettyShow <$> trans'
flags = ("-package-id " ++) . prettyShow <$>
if includeTransitive then trans' else deps'
-- | This defines what a 'TargetSelector' means for the @repl@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
......
......@@ -18,9 +18,7 @@ import Distribution.Client.ProjectConfig
( ProjectConfig(..)
, ProjectConfigShared(projectConfigConfigFile)
, projectConfigWithSolverRepoContext
, readGlobalConfig
, BadPackageLocations(..), BadPackageLocation(..)
, ProjectConfigProvenance(..) )
, withProjectOrGlobalConfig )
import Distribution.Client.Types
( Repo(..), RemoteRepo(..), isRepoRemote )
import Distribution.Client.HttpUtils
......@@ -45,16 +43,12 @@ import Distribution.Client.IndexUtils
, currentIndexTimestamp, indexBaseName )
import Distribution.Text
( Text(..), display, simpleParse )
import Distribution.Client.RebuildMonad
( runRebuild )
import Data.Maybe (fromJust)
import qualified Distribution.Compat.ReadP as ReadP
import qualified Text.PrettyPrint as Disp
import Control.Monad (mapM, mapM_)
import Control.Exception (catch, throwIO)
import qualified Data.Set as Set
import qualified Data.ByteString.Lazy as BS
import Distribution.Client.GZipUtils (maybeDecompress)
import System.FilePath ((<.>), dropExtension)
......@@ -120,19 +114,9 @@ updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
-> [String] -> GlobalFlags -> IO ()
updateAction (configFlags, configExFlags, installFlags, haddockFlags)
extraArgs globalFlags = do
projectConfig <- catch
projectConfig <- withProjectOrGlobalConfig verbosity globalConfigFlag
(projectConfig <$> establishProjectBaseContext verbosity cliConfig)
$ \case
(BadPackageLocations prov locs)
| prov == Set.singleton Implicit
, let
isGlobErr (BadLocGlobEmptyMatch _) = True
isGlobErr _ = False
, any isGlobErr locs -> do
let globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
return (globalConfig <> cliConfig)
err -> throwIO err
(\globalConfig -> return $ globalConfig <> cliConfig)
projectConfigWithSolverRepoContext verbosity
(projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig)
......@@ -185,6 +169,7 @@ updateAction (configFlags, configExFlags, installFlags, haddockFlags)
cliConfig = commandLineFlagsToProjectConfig
globalFlags configFlags configExFlags
installFlags haddockFlags
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState)
-> IO ()
......
{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveDataTypeable #-}
{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveDataTypeable, LambdaCase #-}
-- | Handling project configuration.
--
......@@ -22,6 +22,7 @@ module Distribution.Client.ProjectConfig (
readProjectConfig,
readGlobalConfig,
readProjectLocalFreezeConfig,
withProjectOrGlobalConfig,
writeProjectLocalExtraConfig,
writeProjectLocalFreezeConfig,
writeProjectConfigFile,
......@@ -438,6 +439,30 @@ renderBadProjectRoot :: BadProjectRoot -> String
renderBadProjectRoot (BadProjectRootExplicitFile projectFile) =
"The given project file '" ++ projectFile ++ "' does not exist."
withProjectOrGlobalConfig :: Verbosity
-> Flag FilePath
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig verbosity globalConfigFlag with without = do
globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
let
res' = catch with
$ \case
(BadPackageLocations prov locs)
| prov == Set.singleton Implicit
, let
isGlobErr (BadLocGlobEmptyMatch _) = True
isGlobErr _ = False
, any isGlobErr locs ->
without globalConfig
err -> throwIO err
catch res'
$ \case
(BadProjectRootExplicitFile "") -> without globalConfig
err -> throwIO err
-- | Read all the config relevant for a project. This includes the project
-- file if any, plus other global config.
......
......@@ -57,6 +57,7 @@ module Distribution.Client.ProjectOrchestration (
resolveTargets,
TargetsMap,
TargetSelector(..),
TargetImplicitCwd(..),
PackageId,
AvailableTarget(..),
AvailableTargetStatus(..),
......@@ -115,7 +116,7 @@ import Distribution.Solver.Types.PackageIndex
( lookupPackageName )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.TargetSelector
( TargetSelector(..)
( TargetSelector(..), TargetImplicitCwd(..)
, ComponentKind(..), componentKind
, readTargetSelectors, reportTargetSelectorProblems )
import Distribution.Client.DistDirLayout
......
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