diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs --- a/Distribution/Client/BuildReports/Anonymous.hs +++ b/Distribution/Client/BuildReports/Anonymous.hs @@ -26,6 +26,9 @@ -- showList, ) where +import Prelude () +import Distribution.Client.Compat.Prelude hiding (show) + import qualified Distribution.Client.Types as BR ( BuildOutcome, BuildFailure(..), BuildResult(..) , DocsResult(..), TestsResult(..) ) @@ -36,7 +39,8 @@ import Distribution.Package ( PackageIdentifier(..), mkPackageName ) import Distribution.PackageDescription - ( FlagName, mkFlagName, unFlagName, FlagAssignment ) + ( FlagName, mkFlagName, unFlagName + , FlagAssignment, mkFlagAssignment, unFlagAssignment ) import Distribution.Version ( mkVersion' ) import Distribution.System @@ -57,15 +61,11 @@ import qualified Text.PrettyPrint as Disp ( Doc, render, char, text ) import Text.PrettyPrint - ( (<+>), (<>) ) + ( (<+>) ) -import Data.List - ( unfoldr, sortBy ) import Data.Char as Char ( isAlpha, isAlphaNum ) -import Prelude hiding (show) - data BuildReport = BuildReport { -- | The package this build report is about @@ -173,7 +173,7 @@ arch = requiredField "arch", compiler = requiredField "compiler", client = requiredField "client", - flagAssignment = [], + flagAssignment = mempty, dependencies = [], installOutcome = requiredField "install-outcome", -- cabalVersion = Nothing, @@ -194,7 +194,7 @@ parseFields :: String -> ParseResult BuildReport parseFields input = do - fields <- mapM extractField =<< readFields input + fields <- traverse extractField =<< readFields input let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name) sortedFieldDescrs (sortBy (comparing (\(_,name,_) -> name)) fields) @@ -249,7 +249,8 @@ , simpleField "client" Text.disp Text.parse client (\v r -> r { client = v }) , listField "flags" dispFlag parseFlag - flagAssignment (\v r -> r { flagAssignment = v }) + (unFlagAssignment . flagAssignment) + (\v r -> r { flagAssignment = mkFlagAssignment v }) , listField "dependencies" Text.disp Text.parse dependencies (\v r -> r { dependencies = v }) , simpleField "install-outcome" Text.disp Text.parse @@ -265,7 +266,7 @@ dispFlag :: (FlagName, Bool) -> Disp.Doc dispFlag (fname, True) = Disp.text (unFlagName fname) -dispFlag (fname, False) = Disp.char '-' <> Disp.text (unFlagName fname) +dispFlag (fname, False) = Disp.char '-' <<>> Disp.text (unFlagName fname) parseFlag :: Parse.ReadP r (FlagName, Bool) parseFlag = do diff --git a/Distribution/Client/BuildReports/Storage.hs b/Distribution/Client/BuildReports/Storage.hs --- a/Distribution/Client/BuildReports/Storage.hs +++ b/Distribution/Client/BuildReports/Storage.hs @@ -51,7 +51,7 @@ import Data.List ( groupBy, sortBy ) import Data.Maybe - ( catMaybes ) + ( mapMaybe ) import System.FilePath ( (), takeDirectory ) import System.Directory @@ -126,10 +126,9 @@ -> BuildOutcomes -> [(BuildReport, Maybe Repo)] fromInstallPlan platform comp plan buildOutcomes = - catMaybes - . map (\pkg -> fromPlanPackage - platform comp pkg - (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) + mapMaybe (\pkg -> fromPlanPackage + platform comp pkg + (InstallPlan.lookupBuildOutcome pkg buildOutcomes)) . InstallPlan.toList $ plan diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs --- a/Distribution/Client/Check.hs +++ b/Distribution/Client/Check.hs @@ -16,26 +16,42 @@ check ) where -import Control.Monad ( when, unless ) - -#ifdef CABAL_PARSEC -import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) -#else -import Distribution.PackageDescription.Parse ( readGenericPackageDescription ) -#endif +import Distribution.Client.Compat.Prelude +import Prelude () +import Distribution.PackageDescription (GenericPackageDescription) import Distribution.PackageDescription.Check -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Simple.Utils - ( defaultPackageDesc, toUTF8, wrapText ) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.PackageDescription.Parsec + (parseGenericPackageDescription, runParseResult) +import Distribution.Parsec.Common (PWarning (..), showPError, showPWarning) +import Distribution.Simple.Utils (defaultPackageDesc, die', warn, wrapText) +import Distribution.Verbosity (Verbosity) +import qualified Data.ByteString as BS +import qualified System.Directory as Dir + +readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription) +readGenericPackageDescriptionCheck verbosity fpath = do + exists <- Dir.doesFileExist fpath + unless exists $ + die' verbosity $ + "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." + bs <- BS.readFile fpath + let (warnings, result) = runParseResult (parseGenericPackageDescription bs) + case result of + Left (_, errors) -> do + traverse_ (warn verbosity . showPError fpath) errors + die' verbosity $ "Failed parsing \"" ++ fpath ++ "\"." + Right x -> return (warnings, x) + check :: Verbosity -> IO Bool check verbosity = do pdfile <- defaultPackageDesc verbosity - ppd <- readGenericPackageDescription verbosity pdfile + (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile + -- convert parse warnings into PackageChecks + -- Note: we /could/ pick different levels, based on warning type. + let ws' = [ PackageDistSuspicious (showPWarning pdfile w) | w <- ws ] -- flatten the generic package description into a regular package -- description -- TODO: this may give more warnings than it should give; @@ -51,7 +67,7 @@ -- the exact same errors as it will. let pkg_desc = flattenPackageDescription ppd ioChecks <- checkPackageFiles pkg_desc "." - let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) + let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws' buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] @@ -87,8 +103,8 @@ when (null packageChecks) $ putStrLn "No errors or warnings could be found in the package." - return (null . filter isCheckError $ packageChecks) + return (not . any isCheckError $ packageChecks) where - printCheckMessages = mapM_ (putStrLn . format . explanation) - format = toUTF8 . wrapText . ("* "++) + printCheckMessages = traverse_ (putStrLn . format . explanation) + format = wrapText . ("* "++) diff --git a/Distribution/Client/CmdBench.hs b/Distribution/Client/CmdBench.hs --- a/Distribution/Client/CmdBench.hs +++ b/Distribution/Client/CmdBench.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: bench -- @@ -18,8 +17,7 @@ import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags - , applyFlagDefaults ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -77,7 +75,7 @@ -- benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -benchAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) +benchAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig @@ -105,10 +103,10 @@ targetSelectors let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild + TargetActionBench targets elaboratedPlan - return elaboratedPlan' + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx @@ -127,7 +125,7 @@ -- For the @bench@ command we select all buildable benchmarks, -- or fail if there are no benchmarks or no buildable benchmarks. -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -162,17 +160,20 @@ -- For the @bench@ command we just need to check it is a benchmark, in addition -- to the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget@WholeComponent t +selectComponentTarget subtarget@WholeComponent t | CBenchName _ <- availableTargetComponentName t = either (Left . TargetProblemCommon) return $ - selectComponentTargetBasic pkgid cname subtarget t + selectComponentTargetBasic subtarget t | otherwise - = Left (TargetProblemComponentNotBenchmark pkgid cname) + = Left (TargetProblemComponentNotBenchmark (availableTargetPackageId t) + (availableTargetComponentName t)) -selectComponentTarget pkgid cname subtarget _ - = Left (TargetProblemIsSubComponent pkgid cname subtarget) +selectComponentTarget subtarget t + = Left (TargetProblemIsSubComponent (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. @@ -181,13 +182,13 @@ TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches benchmarks but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector -- | The 'TargetSelector' matches targets but no benchmarks - | TargetProblemNoBenchmarks (TargetSelector PackageId) + | TargetProblemNoBenchmarks TargetSelector -- | The 'TargetSelector' refers to a component that is not a benchmark | TargetProblemComponentNotBenchmark PackageId ComponentName @@ -222,10 +223,6 @@ ++ renderTargetSelector targetSelector ++ "." _ -> renderTargetProblemNoTargets "benchmark" targetSelector - where - targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter - targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter - targetSelectorFilter (TargetComponent _ _ _) = Nothing renderTargetProblem (TargetProblemComponentNotBenchmark pkgid cname) = "The bench command is for running benchmarks, but the target '" diff --git a/Distribution/Client/CmdBuild.hs b/Distribution/Client/CmdBuild.hs --- a/Distribution/Client/CmdBuild.hs +++ b/Distribution/Client/CmdBuild.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} - -- | cabal-install CLI command: build -- module Distribution.Client.CmdBuild ( @@ -17,8 +15,7 @@ import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags - , applyFlagDefaults ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -75,7 +72,7 @@ -- buildAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -buildAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) +buildAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig @@ -107,7 +104,7 @@ elaboratedPlan' else return elaboratedPlan' - return elaboratedPlan'' + return (elaboratedPlan'', targets) printPlan verbosity baseCtx buildCtx @@ -126,7 +123,7 @@ -- For the @build@ command select all components except non-buildable and disabled -- tests\/benchmarks, fail if there are no such components -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -159,11 +156,11 @@ -- -- For the @build@ command we just need the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget = +selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right - . selectComponentTargetBasic pkgid cname subtarget + . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a @@ -173,10 +170,10 @@ TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector deriving (Eq, Show) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a diff --git a/Distribution/Client/CmdConfigure.hs b/Distribution/Client/CmdConfigure.hs --- a/Distribution/Client/CmdConfigure.hs +++ b/Distribution/Client/CmdConfigure.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: configure -- module Distribution.Client.CmdConfigure ( @@ -6,13 +5,16 @@ configureAction, ) where +import System.Directory +import Control.Monad +import qualified Data.Map as Map + import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig ( writeProjectLocalExtraConfig ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags - , applyFlagDefaults ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Verbosity @@ -21,7 +23,7 @@ import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Utils - ( wrapText ) + ( wrapText, notice ) import qualified Distribution.Client.Setup as Client configureCommand :: CommandUI (ConfigFlags, ConfigExFlags @@ -78,25 +80,30 @@ -- configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -configureAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) +configureAction (configFlags, configExFlags, installFlags, haddockFlags) _extraArgs globalFlags = do --TODO: deal with _extraArgs, since flags with wrong syntax end up there baseCtx <- establishProjectBaseContext verbosity cliConfig -- Write out the @cabal.project.local@ so it gets picked up by the - -- planning phase. + -- planning phase. If old config exists, then print the contents + -- before overwriting + exists <- doesFileExist "cabal.project.local" + when exists $ do + notice verbosity "'cabal.project.local' file already exists. Now overwriting it." + copyFile "cabal.project.local" "cabal.project.local~" writeProjectLocalExtraConfig (distDirLayout baseCtx) cliConfig buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> -- TODO: Select the same subset of targets as 'CmdBuild' would -- pick (ignoring, for example, executables in libraries -- we depend on). But we don't want it to fail, so actually we -- have to do it slightly differently from build. - return elaboratedPlan + return (elaboratedPlan, Map.empty) let baseCtx' = baseCtx { buildSettings = (buildSettings baseCtx) { diff --git a/Distribution/Client/CmdErrorMessages.hs b/Distribution/Client/CmdErrorMessages.hs --- a/Distribution/Client/CmdErrorMessages.hs +++ b/Distribution/Client/CmdErrorMessages.hs @@ -9,10 +9,10 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.TargetSelector - ( componentKind, showTargetSelector ) + ( ComponentKindFilter, componentKind, showTargetSelector ) import Distribution.Package - ( packageId, packageName ) + ( packageId, PackageName, packageName ) import Distribution.Types.ComponentName ( showComponentName ) import Distribution.Solver.Types.OptionalStanza @@ -84,14 +84,23 @@ -- Renderering for a few project and package types -- -renderTargetSelector :: TargetSelector PackageId -> String -renderTargetSelector (TargetPackage _ pkgid Nothing) = - "the package " ++ display pkgid +renderTargetSelector :: TargetSelector -> String +renderTargetSelector (TargetPackage _ pkgids Nothing) = + "the " ++ plural (listPlural pkgids) "package" "packages" ++ " " + ++ renderListCommaAnd (map display pkgids) -renderTargetSelector (TargetPackage _ pkgid (Just kfilter)) = +renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) = "the " ++ renderComponentKind Plural kfilter - ++ " in the package " ++ display pkgid + ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " " + ++ renderListCommaAnd (map display pkgids) +renderTargetSelector (TargetPackageNamed pkgname Nothing) = + "the package " ++ display pkgname + +renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) = + "the " ++ renderComponentKind Plural kfilter + ++ " in the package " ++ display pkgname + renderTargetSelector (TargetAllPackages Nothing) = "all the packages in the project" @@ -99,17 +108,24 @@ "all the " ++ renderComponentKind Plural kfilter ++ " in the project" -renderTargetSelector (TargetComponent pkgid CLibName WholeComponent) = - "the library in the package " ++ display pkgid +renderTargetSelector (TargetComponent pkgid cname subtarget) = + renderSubComponentTarget subtarget ++ "the " + ++ renderComponentName (packageName pkgid) cname -renderTargetSelector (TargetComponent _pkgid cname WholeComponent) = - "the " ++ showComponentName cname +renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) = + renderSubComponentTarget subtarget ++ "the component " ++ display ucname + ++ " in the package " ++ display pkgname -renderTargetSelector (TargetComponent _pkgid cname (FileTarget filename)) = - "the file " ++ filename ++ " in the " ++ showComponentName cname +renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) = + renderSubComponentTarget subtarget ++ "the " + ++ renderComponentName pkgname cname -renderTargetSelector (TargetComponent _pkgid cname (ModuleTarget modname)) = - "the module " ++ display modname ++ " in the " ++ showComponentName cname +renderSubComponentTarget :: SubComponentTarget -> String +renderSubComponentTarget WholeComponent = "" +renderSubComponentTarget (FileTarget filename) = + "the file " ++ filename ++ "in " +renderSubComponentTarget (ModuleTarget modname) = + "the module" ++ display modname ++ "in " renderOptionalStanza :: Plural -> OptionalStanza -> String @@ -124,20 +140,38 @@ optionalStanza (CBenchName _) = Just BenchStanzas optionalStanza _ = Nothing - -- | Does the 'TargetSelector' potentially refer to one package or many? -- -targetSelectorPluralPkgs :: TargetSelector a -> Plural +targetSelectorPluralPkgs :: TargetSelector -> Plural targetSelectorPluralPkgs (TargetAllPackages _) = Plural -targetSelectorPluralPkgs (TargetPackage _ _ _) = Singular -targetSelectorPluralPkgs (TargetComponent _ _ _) = Singular +targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids +targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular +targetSelectorPluralPkgs TargetComponent{} = Singular +targetSelectorPluralPkgs TargetComponentUnknown{} = Singular --- | Does the 'TargetSelector' refer to -targetSelectorRefersToPkgs :: TargetSelector a -> Bool -targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetComponent _ _ _) = False +-- | Does the 'TargetSelector' refer to packages or to components? +targetSelectorRefersToPkgs :: TargetSelector -> Bool +targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs TargetComponent{} = False +targetSelectorRefersToPkgs TargetComponentUnknown{} = False +targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter +targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter +targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter +targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter +targetSelectorFilter TargetComponent{} = Nothing +targetSelectorFilter TargetComponentUnknown{} = Nothing + +renderComponentName :: PackageName -> ComponentName -> String +renderComponentName pkgname CLibName = "library " ++ display pkgname +renderComponentName _ (CSubLibName name) = "library " ++ display name +renderComponentName _ (CFLibName name) = "foreign library " ++ display name +renderComponentName _ (CExeName name) = "executable " ++ display name +renderComponentName _ (CTestName name) = "test suite " ++ display name +renderComponentName _ (CBenchName name) = "benchmark " ++ display name + renderComponentKind :: Plural -> ComponentKind -> String renderComponentKind Singular ckind = case ckind of LibKind -> "library" -- internal/sub libs? @@ -197,7 +231,7 @@ "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " ++ "solver did not find a plan that included the " ++ compkinds ++ " for " ++ display pkgid ++ ". It is probably worth trying again with " - ++ compkinds ++ "explicitly enabled in the configuration in the " + ++ compkinds ++ " explicitly enabled in the configuration in the " ++ "cabal.project{.local} file. This will ask the solver to find a plan with " ++ "the " ++ compkinds ++ " available. It will either fail with an " ++ "explanation or find a different plan that uses different versions of some " @@ -206,6 +240,18 @@ where compkinds = renderComponentKind Plural (componentKind cname) +renderTargetProblemCommon verb (TargetProblemUnknownComponent pkgname ecname) = + "Cannot " ++ verb ++ " the " + ++ (case ecname of + Left ucname -> "component " ++ display ucname + Right cname -> renderComponentName pkgname cname) + ++ " from the package " ++ display pkgname + ++ ", because the package does not contain a " + ++ (case ecname of + Left _ -> "component" + Right cname -> renderComponentKind Singular (componentKind cname)) + ++ " with that name." + renderTargetProblemCommon verb (TargetProblemNoSuchPackage pkgid) = "Internal error when trying to " ++ verb ++ " the package " ++ display pkgid ++ ". The package is not in the set of available targets " @@ -228,7 +274,7 @@ -- This renders an error message for those cases. -- renderTargetProblemNoneEnabled :: String - -> TargetSelector PackageId + -> TargetSelector -> [AvailableTarget ()] -> String renderTargetProblemNoneEnabled verb targetSelector targets = @@ -290,7 +336,7 @@ -- | Several commands have a @TargetProblemNoTargets@ problem constructor. -- This renders an error message for those cases. -- -renderTargetProblemNoTargets :: String -> TargetSelector PackageId -> String +renderTargetProblemNoTargets :: String -> TargetSelector -> String renderTargetProblemNoTargets verb targetSelector = "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector ++ " because " ++ reason targetSelector ++ ". " @@ -304,12 +350,18 @@ "it does not contain any components at all" reason (TargetPackage _ _ (Just kfilter)) = "it does not contain any " ++ renderComponentKind Plural kfilter + reason (TargetPackageNamed _ Nothing) = + "it does not contain any components at all" + reason (TargetPackageNamed _ (Just kfilter)) = + "it does not contain any " ++ renderComponentKind Plural kfilter reason (TargetAllPackages Nothing) = "none of them contain any components at all" reason (TargetAllPackages (Just kfilter)) = "none of the packages contain any " ++ renderComponentKind Plural kfilter reason ts@TargetComponent{} = + error $ "renderTargetProblemNoTargets: " ++ show ts + reason ts@TargetComponentUnknown{} = error $ "renderTargetProblemNoTargets: " ++ show ts ----------------------------------------------------------- diff --git a/Distribution/Client/CmdExec.hs b/Distribution/Client/CmdExec.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdExec.hs @@ -0,0 +1,259 @@ +------------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Exec +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'new-exec' command for running an arbitrary executable +-- in an environment suited to the part of the store built for a project. +------------------------------------------------------------------------------- + +{-# LANGUAGE RecordWildCards #-} +module Distribution.Client.CmdExec + ( execAction + , execCommand + ) where + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..) + ) +import Distribution.Client.InstallPlan + ( GenericPlanPackage(..) + , toGraph + ) +import Distribution.Client.Setup + ( ConfigExFlags + , ConfigFlags(configVerbosity) + , GlobalFlags + , InstallFlags + ) +import Distribution.Client.ProjectOrchestration + ( ProjectBuildContext(..) + , runProjectPreBuildPhase + , establishProjectBaseContext + , distDirLayout + , commandLineFlagsToProjectConfig + , ProjectBaseContext(..) + ) +import Distribution.Client.ProjectPlanOutput + ( updatePostBuildProjectStatus + , createPackageEnvironment + , argsEquivalentOfGhcEnvironmentFile + , PostBuildProjectStatus + ) +import qualified Distribution.Client.ProjectPlanning as Planning +import Distribution.Client.ProjectPlanning + ( ElaboratedInstallPlan + , ElaboratedSharedConfig(..) + ) +import Distribution.Simple.Command + ( CommandUI(..) + ) +import Distribution.Simple.Program.Db + ( modifyProgramSearchPath + , requireProgram + , configuredPrograms + ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry(..) + ) +import Distribution.Simple.Program.Run + ( programInvocation + , runProgramInvocation + ) +import Distribution.Simple.Program.Types + ( programOverrideEnv + , programDefaultArgs + , programPath + , simpleProgram + , ConfiguredProgram + ) +import Distribution.Simple.GHC + ( getImplInfo + , GhcImplInfo(supportsPkgEnvFiles) ) +import Distribution.Simple.Setup + ( HaddockFlags + , fromFlagOrDefault + ) +import Distribution.Simple.Utils + ( die' + , info + , withTempDirectory + , wrapText + ) +import Distribution.Verbosity + ( Verbosity + , normal + ) + +import qualified Distribution.Client.CmdBuild as CmdBuild + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Map as M + +execCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +execCommand = CommandUI + { commandName = "new-exec" + , commandSynopsis = "Give a command access to the store." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " new-exec [FLAGS] [--] COMMAND [--] [ARGS]\n" + , commandDescription = Just $ \pname -> wrapText $ + "During development it is often useful to run build tasks and perform" + ++ " one-off program executions to experiment with the behavior of build" + ++ " tools. It is convenient to run these tools in the same way " ++ pname + ++ " itself would. The `" ++ pname ++ " new-exec` command provides a way to" + ++ " do so.\n" + ++ "\n" + ++ "Compiler tools will be configured to see the same subset of the store" + ++ " that builds would see. The PATH is modified to make all executables in" + ++ " the dependency tree available (provided they have been built already)." + ++ " Commands are also rewritten in the way cabal itself would. For" + ++ " example, `" ++ pname ++ " new-exec ghc` will consult the configuration" + ++ " to choose an appropriate version of ghc and to include any" + ++ " ghc-specific flags requested." + , commandNotes = Nothing + , commandOptions = commandOptions CmdBuild.buildCommand + , commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand + } + +execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +execAction (configFlags, configExFlags, installFlags, haddockFlags) + extraArgs globalFlags = do + + baseCtx <- establishProjectBaseContext verbosity cliConfig + + -- To set up the environment, we'd like to select the libraries in our + -- dependency tree that we've already built. So first we set up an install + -- plan, but we walk the dependency tree without first executing the plan. + buildCtx <- runProjectPreBuildPhase + verbosity + baseCtx + (\plan -> return (plan, M.empty)) + + -- We use the build status below to decide what libraries to include in the + -- compiler environment, but we don't want to actually build anything. So we + -- pass mempty to indicate that nothing happened and we just want the current + -- status. + buildStatus <- updatePostBuildProjectStatus + verbosity + (distDirLayout baseCtx) + (elaboratedPlanOriginal buildCtx) + (pkgsBuildStatus buildCtx) + mempty + + -- Some dependencies may have executables. Let's put those on the PATH. + extraPaths <- pathAdditions verbosity baseCtx buildCtx + let programDb = modifyProgramSearchPath + (map ProgramSearchPathDir extraPaths ++) + . pkgConfigCompilerProgs + . elaboratedShared + $ buildCtx + + -- Now that we have the packages, set up the environment. We accomplish this + -- by creating an environment file that selects the databases and packages we + -- computed in the previous step, and setting an environment variable to + -- point at the file. + -- In case ghc is too old to support environment files, + -- we pass the same info as arguments + let compiler = pkgConfigCompiler $ elaboratedShared buildCtx + envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) + case extraArgs of + [] -> die' verbosity "Please specify an executable to run" + exe:args -> do + (program, _) <- requireProgram verbosity (simpleProgram exe) programDb + let argOverrides = + argsEquivalentOfGhcEnvironmentFile + compiler + (distDirLayout baseCtx) + (elaboratedPlanOriginal buildCtx) + buildStatus + programIsConfiguredCompiler = matchCompilerPath + (elaboratedShared buildCtx) + program + argOverrides' = + if envFilesSupported + || not programIsConfiguredCompiler + then [] + else argOverrides + + (if envFilesSupported + then withTempEnvFile verbosity baseCtx buildCtx buildStatus + else \f -> f []) $ \envOverrides -> do + let program' = withOverrides + envOverrides + argOverrides' + program + invocation = programInvocation program' args + runProgramInvocation verbosity invocation + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + withOverrides env args program = program + { programOverrideEnv = programOverrideEnv program ++ env + , programDefaultArgs = programDefaultArgs program ++ args} + +matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool +matchCompilerPath elaboratedShared program = + programPath program + `elem` + (programPath <$> configuredCompilers) + where + configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared + +-- | Execute an action with a temporary .ghc.environment file reflecting the +-- current environment. The action takes an environment containing the env +-- variable which points ghc to the file. +withTempEnvFile :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> PostBuildProjectStatus + -> ([(String, Maybe String)] -> IO a) + -> IO a +withTempEnvFile verbosity + baseCtx + buildCtx + buildStatus + action = + withTempDirectory + verbosity + (distTempDirectory (distDirLayout baseCtx)) + "environment." + (\tmpDir -> do + envOverrides <- createPackageEnvironment + verbosity + tmpDir + (elaboratedPlanToExecute buildCtx) + (elaboratedShared buildCtx) + buildStatus + action envOverrides) + +pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath] +pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do + info verbosity . unlines $ "Including the following directories in PATH:" + : paths + return paths + where + paths = S.toList + $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute + +binDirectories + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> Set FilePath +binDirectories layout config = fromElaboratedInstallPlan where + fromElaboratedInstallPlan = fromGraph . toGraph + fromGraph = foldMap fromPlan + fromSrcPkg = S.fromList . Planning.binDirectories layout config + + fromPlan (PreExisting _) = mempty + fromPlan (Configured pkg) = fromSrcPkg pkg + fromPlan (Installed pkg) = fromSrcPkg pkg + diff --git a/Distribution/Client/CmdFreeze.hs b/Distribution/Client/CmdFreeze.hs --- a/Distribution/Client/CmdFreeze.hs +++ b/Distribution/Client/CmdFreeze.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns #-} +{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-} -- | cabal-install CLI command: freeze -- @@ -29,14 +29,13 @@ ( VersionRange, thisVersion , unionVersionRanges, simplifyVersionRange ) import Distribution.PackageDescription - ( FlagAssignment ) + ( FlagAssignment, nullFlagAssignment ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags - , applyFlagDefaults ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Utils - ( die', notice ) + ( die', notice, wrapText ) import Distribution.Verbosity ( normal ) @@ -47,8 +46,6 @@ import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) -import Distribution.Simple.Utils - ( wrapText ) import qualified Distribution.Client.Setup as Client @@ -104,7 +101,7 @@ -- freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -freezeAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) +freezeAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do unless (null extraArgs) $ @@ -175,7 +172,7 @@ versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] versionConstraints = Map.mapWithKey - (\p v -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyVersion v), + (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v), ConstraintSourceFreeze)]) versionRanges @@ -204,7 +201,7 @@ | InstallPlan.Configured elab <- InstallPlan.toList plan , let flags = elabFlagAssignment elab pkgname = packageName elab - , not (null flags) ] + , not (nullFlagAssignment flags) ] -- As described above, remove the version constraints on local packages, -- but leave any flag constraints. diff --git a/Distribution/Client/CmdHaddock.hs b/Distribution/Client/CmdHaddock.hs --- a/Distribution/Client/CmdHaddock.hs +++ b/Distribution/Client/CmdHaddock.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: haddock -- @@ -18,11 +17,10 @@ import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags - , applyFlagDefaults ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags(..), fromFlagOrDefault, fromFlag ) + ( HaddockFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity @@ -73,7 +71,7 @@ -- haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -haddockAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) +haddockAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig @@ -102,7 +100,7 @@ TargetActionHaddock targets elaboratedPlan - return elaboratedPlan' + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx @@ -122,7 +120,7 @@ -- depending on the @--executables@ flag we also select all the buildable exes. -- We do similarly for test-suites, benchmarks and foreign libs. -- -selectPackageTargets :: HaddockFlags -> TargetSelector PackageId +selectPackageTargets :: HaddockFlags -> TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets haddockFlags targetSelector targets @@ -153,23 +151,30 @@ isRequested (TargetAllPackages (Just _)) _ = True isRequested _ LibKind = True -- isRequested _ SubLibKind = True --TODO: what about sublibs? - isRequested _ FLibKind = fromFlag (haddockForeignLibs haddockFlags) - isRequested _ ExeKind = fromFlag (haddockExecutables haddockFlags) - isRequested _ TestKind = fromFlag (haddockTestSuites haddockFlags) - isRequested _ BenchKind = fromFlag (haddockBenchmarks haddockFlags) + -- TODO/HACK, we encode some defaults here as new-haddock's logic; + -- make sure this matches the defaults applied in + -- "Distribution.Client.ProjectPlanning"; this may need more work + -- to be done properly + -- + -- See also https://github.com/haskell/cabal/pull/4886 + isRequested _ FLibKind = fromFlagOrDefault False (haddockForeignLibs haddockFlags) + isRequested _ ExeKind = fromFlagOrDefault False (haddockExecutables haddockFlags) + isRequested _ TestKind = fromFlagOrDefault False (haddockTestSuites haddockFlags) + isRequested _ BenchKind = fromFlagOrDefault False (haddockBenchmarks haddockFlags) + -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- -- For the @haddock@ command we just need the basic checks on being buildable -- etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget = +selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right - . selectComponentTargetBasic pkgid cname subtarget + . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a @@ -179,10 +184,10 @@ TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector deriving (Eq, Show) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a diff --git a/Distribution/Client/CmdInstall.hs b/Distribution/Client/CmdInstall.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdInstall.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | cabal-install CLI command: build +-- +module Distribution.Client.CmdInstall ( + -- * The @build@ CLI and action + installCommand, + installAction, + + -- * Internals exposed for testing + TargetProblem(..), + selectPackageTargets, + selectComponentTarget + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.ProjectOrchestration +import Distribution.Client.CmdErrorMessages + +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) +import Distribution.Client.Types + ( PackageSpecifier(NamedPackage), UnresolvedSourcePackage ) +import Distribution.Client.ProjectPlanning.Types + ( pkgConfigCompiler ) +import Distribution.Client.ProjectConfig.Types + ( ProjectConfig, ProjectConfigBuildOnly(..) + , projectConfigLogsDir, projectConfigStoreDir, projectConfigShared + , projectConfigBuildOnly, projectConfigDistDir + , projectConfigConfigFile ) +import Distribution.Client.Config + ( defaultCabalDir ) +import Distribution.Client.ProjectConfig + ( readGlobalConfig, resolveBuildTimeSettings ) +import Distribution.Client.DistDirLayout + ( defaultDistDirLayout, distDirectory, mkCabalDirLayout + , ProjectRoot(ProjectRootImplicit), distProjectCacheDirectory + , storePackageDirectory, cabalStoreDirLayout ) +import Distribution.Client.RebuildMonad + ( runRebuild ) +import Distribution.Client.InstallSymlink + ( symlinkBinary ) +import Distribution.Simple.Setup + ( Flag(Flag), HaddockFlags, fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import Distribution.Simple.Compiler + ( compilerId ) +import Distribution.Types.PackageName + ( mkPackageName ) +import Distribution.Types.UnitId + ( UnitId ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText, die', notice + , withTempDirectory, createDirectoryIfMissingVerbose ) + +import qualified Data.Map as Map +import System.Directory ( getTemporaryDirectory, makeAbsolute ) +import System.FilePath ( () ) + +import qualified Distribution.Client.CmdBuild as CmdBuild + +installCommand :: CommandUI (ConfigFlags, ConfigExFlags + ,InstallFlags, HaddockFlags) +installCommand = CommandUI + { commandName = "new-install" + , commandSynopsis = "Install packages." + , commandUsage = usageAlternatives + "new-install" [ "[TARGETS] [FLAGS]" ] + , commandDescription = Just $ \_ -> wrapText $ + "Installs one or more packages. This is done by installing them " + ++ "in the store and symlinking the executables in the directory " + ++ "specified by the --symlink-bindir flag (`~/.cabal/bin/` by default). " + ++ "If you want the installed executables to be available globally, " + ++ "make sure that the PATH environment variable contains that directory. " + ++ "\n\n" + ++ "If TARGET is a library, it will be added to the global environment. " + ++ "When doing this, cabal will try to build a plan that includes all " + ++ "the previously installed libraries. This is currently not implemented." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " new-install\n" + ++ " Install the package in the current directory\n" + ++ " " ++ pname ++ " new-install pkgname\n" + ++ " Install the package named pkgname" + ++ " (fetching it from hackage if necessary)\n" + ++ " " ++ pname ++ " new-install ./pkgfoo\n" + ++ " Install the package in the ./pkgfoo directory\n" + + ++ cmdCommonHelpTextNewBuildBeta + , commandOptions = commandOptions CmdBuild.buildCommand + , commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand + } + + +-- | The @install@ command actually serves four different needs. It installs: +-- * Nonlocal exes: +-- For example a program from hackage. The behavior is similar to the old +-- install command, except that now conflicts between separate runs of the +-- command are impossible thanks to the store. +-- Exes are installed in the store like a normal dependency, then they are +-- symlinked uin the directory specified by --symlink-bindir. +-- To do this we need a dummy projectBaseContext containing the targets as +-- estra packages and using a temporary dist directory. +-- * Nonlocal libraries (TODO see #4558) +-- * Local exes (TODO see #4558) +-- * Local libraries (TODO see #4558) +-- +-- For more details on how this works, see the module +-- "Distribution.Client.ProjectOrchestration" +-- +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +installAction (configFlags, configExFlags, installFlags, haddockFlags) + targetStrings globalFlags = do + -- We never try to build tests/benchmarks for remote packages. + -- So we set them as disabled by default and error if they are explicitly + -- enabled. + when (configTests configFlags' == Flag True) $ + die' verbosity $ "--enable-tests was specified, but tests can't " + ++ "be enabled in a remote package" + when (configBenchmarks configFlags' == Flag True) $ + die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " + ++ "be enabled in a remote package" + + -- We need a place to put a temporary dist directory + globalTmp <- getTemporaryDirectory + withTempDirectory + verbosity + globalTmp + "cabal-install." + $ \tmpDir -> do + + let packageNames = mkPackageName <$> targetStrings + packageSpecifiers = + (\pname -> NamedPackage pname []) <$> packageNames + + baseCtx <- establishDummyProjectBaseContext + verbosity + cliConfig + tmpDir + packageSpecifiers + + let targetSelectors = [ TargetPackageNamed pn Nothing + | pn <- packageNames ] + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + + -- Interpret the targets on the command line as build targets + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + elaboratedPlan'' <- + if buildSettingOnlyDeps (buildSettings baseCtx) + then either (reportCannotPruneDependencies verbosity) return $ + pruneInstallPlanToDependencies (Map.keysSet targets) + elaboratedPlan' + else return elaboratedPlan' + + return (elaboratedPlan'', targets) + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + + let compiler = pkgConfigCompiler $ elaboratedShared buildCtx + let mkPkgBinDir = ( "bin") . + storePackageDirectory + (cabalStoreDirLayout $ cabalDirLayout baseCtx) + (compilerId compiler) + + -- If there are exes, symlink them + let symlinkBindirUnknown = + "symlink-bindir is not defined. Set it in your cabal config file " + ++ "or use --symlink-bindir=" + symlinkBindir <- fromFlagOrDefault (die' verbosity symlinkBindirUnknown) + $ fmap makeAbsolute + $ projectConfigSymlinkBinDir + $ projectConfigBuildOnly + $ projectConfig $ baseCtx + createDirectoryIfMissingVerbose verbosity False symlinkBindir + traverse_ (symlinkBuiltPackage verbosity mkPkgBinDir symlinkBindir) + $ Map.toList $ targetsMap buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + where + configFlags' = disableTestsBenchsByDefault configFlags + verbosity = fromFlagOrDefault normal (configVerbosity configFlags') + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags' configExFlags + installFlags haddockFlags + + +-- | Disables tests and benchmarks if they weren't explicitly enabled. +disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags +disableTestsBenchsByDefault configFlags = + configFlags { configTests = Flag False <> configTests configFlags + , configBenchmarks = Flag False <> configBenchmarks configFlags } + +-- | Symlink every exe from a package from the store to a given location +symlinkBuiltPackage :: Verbosity + -> (UnitId -> FilePath) -- ^ A function to get an UnitId's + -- store directory + -> FilePath -- ^ Where to put the symlink + -> ( UnitId + , [(ComponentTarget, [TargetSelector])] ) + -> IO () +symlinkBuiltPackage verbosity mkSourceBinDir destDir (pkg, components) = + traverse_ (symlinkBuiltExe verbosity (mkSourceBinDir pkg) destDir) exes + where + exes = catMaybes $ (exeMaybe . fst) <$> components + exeMaybe (ComponentTarget (CExeName exe) _) = Just exe + exeMaybe _ = Nothing + +-- | Symlink a specific exe. +symlinkBuiltExe :: Verbosity -> FilePath -> FilePath -> UnqualComponentName -> IO Bool +symlinkBuiltExe verbosity sourceDir destDir exe = do + notice verbosity $ "Symlinking " ++ unUnqualComponentName exe + symlinkBinary + destDir + sourceDir + exe + $ unUnqualComponentName exe + +-- | 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 + :: Verbosity + -> ProjectConfig + -> FilePath + -- ^ Where to put the dist directory + -> [PackageSpecifier UnresolvedSourcePackage] + -- ^ The packages to be included in the project + -> IO ProjectBaseContext +establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do + + cabalDir <- defaultCabalDir + + -- Create the dist directories + createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout + createDirectoryIfMissingVerbose verbosity True $ + distProjectCacheDirectory distDirLayout + + globalConfig <- runRebuild "" + $ readGlobalConfig verbosity + $ projectConfigConfigFile + $ projectConfigShared cliConfig + let projectConfig = globalConfig <> cliConfig + + let ProjectConfigBuildOnly { + projectConfigLogsDir, + projectConfigStoreDir + } = projectConfigBuildOnly projectConfig + + mlogsDir = flagToMaybe projectConfigLogsDir + mstoreDir = flagToMaybe projectConfigStoreDir + cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + + buildSettings = resolveBuildTimeSettings + verbosity cabalDirLayout + projectConfig + + return ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages, + buildSettings + } + where + mdistDirectory = flagToMaybe + $ projectConfigDistDir + $ projectConfigShared cliConfig + projectRoot = ProjectRootImplicit tmpDir + distDirLayout = defaultDistDirLayout projectRoot + mdistDirectory + +-- | This defines what a 'TargetSelector' means for the @bench@ command. +-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, +-- or otherwise classifies the problem. +-- +-- For the @build@ command select all components except non-buildable +-- and disabled tests\/benchmarks, fail if there are no such +-- components +-- +selectPackageTargets :: TargetSelector + -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets targetSelector targets + + -- If there are any buildable targets then we select those + | not (null targetsBuildable) + = Right targetsBuildable + + -- If there are targets but none are buildable then we report those + | not (null targets) + = Left (TargetProblemNoneEnabled targetSelector targets') + + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + targets' = forgetTargetsDetail targets + targetsBuildable = selectBuildableTargetsWith + (buildable targetSelector) + targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + buildable _ _ = True + +-- | For a 'TargetComponent' 'TargetSelector', check if the component can be +-- selected. +-- +-- For the @build@ command we just need the basic checks on being buildable etc. +-- +selectComponentTarget :: SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget subtarget = + either (Left . TargetProblemCommon) Right + . selectComponentTargetBasic subtarget + + +-- | The various error conditions that can occur when matching a +-- 'TargetSelector' against 'AvailableTarget's for the @build@ command. +-- +data TargetProblem = + TargetProblemCommon TargetProblemCommon + + -- | The 'TargetSelector' matches targets but none are buildable + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] + + -- | There are no targets at all + | TargetProblemNoTargets TargetSelector + deriving (Eq, Show) + +reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a +reportTargetProblems verbosity = + die' verbosity . unlines . map renderTargetProblem + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (TargetProblemCommon problem) = + renderTargetProblemCommon "build" problem +renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) = + renderTargetProblemNoneEnabled "build" targetSelector targets +renderTargetProblem(TargetProblemNoTargets targetSelector) = + renderTargetProblemNoTargets "build" targetSelector + +reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a +reportCannotPruneDependencies verbosity = + die' verbosity . renderCannotPruneDependencies diff --git a/Distribution/Client/CmdRepl.hs b/Distribution/Client/CmdRepl.hs --- a/Distribution/Client/CmdRepl.hs +++ b/Distribution/Client/CmdRepl.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: repl -- @@ -18,8 +17,7 @@ import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags - , applyFlagDefaults ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -89,7 +87,7 @@ -- replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -replAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) +replAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig @@ -126,7 +124,7 @@ TargetActionRepl targets elaboratedPlan - return elaboratedPlan' + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx @@ -153,7 +151,7 @@ -- Fail if there are no buildable lib\/exe components, or if there are -- multiple libs or exes. -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -215,11 +213,11 @@ -- -- For the @repl@ command we just need the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget = +selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right - . selectComponentTargetBasic pkgid cname subtarget + . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a @@ -229,13 +227,13 @@ TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] -- | Multiple 'TargetSelector's match multiple targets | TargetProblemMultipleTargets TargetsMap diff --git a/Distribution/Client/CmdRun.hs b/Distribution/Client/CmdRun.hs --- a/Distribution/Client/CmdRun.hs +++ b/Distribution/Client/CmdRun.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: run -- @@ -14,29 +13,46 @@ selectComponentTarget ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags - , applyFlagDefaults ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Types.ComponentName - ( componentNameString ) + ( showComponentName ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils - ( wrapText, die', ordNub ) + ( wrapText, die', ordNub, info ) +import Distribution.Client.ProjectPlanning + ( ElaboratedConfiguredPackage(..) + , ElaboratedInstallPlan, binDirectoryFor ) +import Distribution.Client.ProjectPlanning.Types + ( dataDirsEnvironmentForPlan ) +import Distribution.Client.InstallPlan + ( toList, foldPlanPackage ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, unUnqualComponentName ) +import Distribution.Simple.Program.Run + ( runProgramInvocation, ProgramInvocation(..), + emptyProgramInvocation ) +import Distribution.Types.UnitId + ( UnitId ) import qualified Data.Map as Map import qualified Data.Set as Set -import Control.Monad (when) +import System.FilePath + ( () ) runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) @@ -46,12 +62,13 @@ commandUsage = usageAlternatives "new-run" [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ], commandDescription = Just $ \pname -> wrapText $ - "Runs the specified executable, first ensuring it is up to date.\n\n" + "Runs the specified executable-like component (an executable, a test, " + ++ "or a benchmark), first ensuring it is up to date.\n\n" - ++ "Any executable in any package in the project can be specified. " - ++ "A package can be specified if contains just one executable. " - ++ "The default is to use the package in the current directory if it " - ++ "contains just one executable.\n\n" + ++ "Any executable-like component in any package in the project can be " + ++ "specified. A package can be specified if contains just one " + ++ "executable-like. The default is to use the package in the current " + ++ "directory if it contains just one executable-like.\n\n" ++ "Extra arguments can be passed to the program, but use '--' to " ++ "separate arguments for the program from arguments for " ++ pname @@ -65,11 +82,11 @@ commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " new-run\n" - ++ " Run the executable in the package in the current directory\n" + ++ " Run the executable-like in the package in the current directory\n" ++ " " ++ pname ++ " new-run foo-tool\n" - ++ " Run the named executable (in any package in the project)\n" + ++ " Run the named executable-like (in any package in the project)\n" ++ " " ++ pname ++ " new-run pkgfoo:foo-tool\n" - ++ " Run the executable 'foo-tool' in the package 'pkgfoo'\n" + ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" ++ " " ++ pname ++ " new-run foo -O2 -- dothing --fooflag\n" ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" @@ -77,22 +94,24 @@ } --- | The @build@ command does a lot. It brings the install plan up to date, --- selects that part of the plan needed by the given or implicit targets and --- then executes the plan. +-- | The @run@ command runs a specified executable-like component, building it +-- first if necessary. The component can be either an executable, a test, +-- or a benchmark. This is particularly useful for passing arguments to +-- exes/tests/benchs by simply appending them after a @--@. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -runAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) +runAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) targetStrings + =<< readTargetSelectors (localPackages baseCtx) + (take 1 targetStrings) -- Drop the exe's args. buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -116,26 +135,112 @@ -- 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] + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- singleExeOrElse + (reportTargetProblems + verbosity + [TargetProblemMultipleTargets targets]) + targets let elaboratedPlan' = pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan - return elaboratedPlan' + return (elaboratedPlan', targets) + (selectedUnitId, selectedComponent) <- + -- Slight duplication with 'runProjectPreBuildPhase'. + singleExeOrElse + (die' verbosity $ "No or multiple targets given, but the run " + ++ "phase has been reached. This is a bug.") + $ targetsMap buildCtx + printPlan verbosity baseCtx buildCtx buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + + let elaboratedPlan = elaboratedPlanToExecute buildCtx + matchingElaboratedConfiguredPackages = + matchingPackagesByUnitId + selectedUnitId + elaboratedPlan + + let exeName = unUnqualComponentName selectedComponent + + -- In the common case, we expect @matchingElaboratedConfiguredPackages@ + -- to consist of a single element that provides a single way of building + -- an appropriately-named executable. In that case we take that + -- package and continue. + -- + -- However, multiple packages/components could provide that + -- executable, or it's possible we don't find the executable anywhere + -- in the build plan. I suppose in principle it's also possible that + -- a single package provides an executable in two different ways, + -- though that's probably a bug if. Anyway it's a good lint to report + -- an error in all of these cases, even if some seem like they + -- shouldn't happen. + pkg <- case matchingElaboratedConfiguredPackages of + [] -> die' verbosity $ "Unknown executable " + ++ exeName + ++ " in package " + ++ display selectedUnitId + [elabPkg] -> do + info verbosity $ "Selecting " + ++ display selectedUnitId + ++ " to supply " ++ exeName + return elabPkg + elabPkgs -> die' verbosity + $ "Multiple matching executables found matching " + ++ exeName + ++ ":\n" + ++ unlines (fmap (\p -> " - in package " ++ display (elabUnitId p)) elabPkgs) + let exePath = binDirectoryFor (distDirLayout baseCtx) + (elaboratedShared buildCtx) + pkg + exeName + exeName + let args = drop 1 targetStrings + runProgramInvocation + verbosity + emptyProgramInvocation { + progInvokePath = exePath, + progInvokeArgs = args, + progInvokeEnv = dataDirsEnvironmentForPlan elaboratedPlan + } where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags +singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleExeOrElse action targetsMap = + case Set.toList . distinctTargetComponents $ targetsMap + of [(unitId, CExeName component)] -> return (unitId, component) + [(unitId, CTestName component)] -> return (unitId, component) + [(unitId, CBenchName component)] -> return (unitId, component) + _ -> action + +-- | Filter the 'ElaboratedInstallPlan' keeping only the +-- 'ElaboratedConfiguredPackage's that match the specified +-- 'UnitId'. +matchingPackagesByUnitId :: UnitId + -> ElaboratedInstallPlan + -> [ElaboratedConfiguredPackage] +matchingPackagesByUnitId uid = + catMaybes + . fmap (foldPlanPackage + (const Nothing) + (\x -> if elabUnitId x == uid + then Just x + else Nothing)) + . toList + -- | This defines what a 'TargetSelector' means for the @run@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, -- or otherwise classifies the problem. @@ -143,7 +248,7 @@ -- For the @run@ command we select the exe if there is only one and it's -- buildable. Fail if there are no or multiple buildable exe components. -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -167,33 +272,40 @@ | otherwise = Left (TargetProblemNoTargets targetSelector) where + -- Targets that can be executed + targetsExecutableLike = + concatMap (\kind -> filterTargetsKind kind targets) + [ExeKind, TestKind, BenchKind] (targetsExesBuildable, - targetsExesBuildable') = selectBuildableTargets' - . filterTargetsKind ExeKind - $ targets + targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike - targetsExes = forgetTargetsDetail - . filterTargetsKind ExeKind - $ targets + targetsExes = forgetTargetsDetail targetsExecutableLike -- | For a 'TargetComponent' 'TargetSelector', check if the component can be -- selected. -- --- For the @run@ command we just need to check it is a executable, in addition +-- For the @run@ command we just need to check it is a executable-like +-- (an executable, a test, or a benchmark), in addition -- to the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget@WholeComponent t - | CExeName _ <- availableTargetComponentName t - = either (Left . TargetProblemCommon) return $ - selectComponentTargetBasic pkgid cname subtarget t - | otherwise - = Left (TargetProblemComponentNotExe pkgid cname) +selectComponentTarget subtarget@WholeComponent t + = case availableTargetComponentName t + of CExeName _ -> component + CTestName _ -> component + CBenchName _ -> component + _ -> Left (TargetProblemComponentNotExe pkgid cname) + where pkgid = availableTargetPackageId t + cname = availableTargetComponentName t + component = either (Left . TargetProblemCommon) return $ + selectComponentTargetBasic subtarget t -selectComponentTarget pkgid cname subtarget _ - = Left (TargetProblemIsSubComponent pkgid cname subtarget) +selectComponentTarget subtarget t + = Left (TargetProblemIsSubComponent (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @run@ command. @@ -201,16 +313,16 @@ data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector -- | The 'TargetSelector' matches targets but no executables - | TargetProblemNoExes (TargetSelector PackageId) + | TargetProblemNoExes TargetSelector -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] -- | Multiple 'TargetSelector's match multiple targets | TargetProblemMultipleTargets TargetsMap @@ -248,21 +360,17 @@ ++ renderTargetSelector targetSelector ++ "." _ -> renderTargetProblemNoTargets "run" targetSelector - where - targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter - targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter - targetSelectorFilter (TargetComponent _ _ _) = Nothing - renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) = "The run command is for running a single executable at once. The target '" ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which includes the executables " - ++ renderListCommaAnd - [ display name - | cname@CExeName{} <- map availableTargetComponentName targets - , let Just name = componentNameString cname - ] + ++ renderTargetSelector targetSelector ++ " which includes " + ++ renderListCommaAnd ( ("the "++) <$> + showComponentName <$> + availableTargetComponentName <$> + foldMap + (\kind -> filterTargetsKind kind targets) + [ExeKind, TestKind, BenchKind] ) ++ "." renderTargetProblem (TargetProblemMultipleTargets selectorMap) = @@ -286,4 +394,3 @@ ++ renderTargetSelector targetSelector ++ "." where targetSelector = TargetComponent pkgid cname subtarget - diff --git a/Distribution/Client/CmdTest.hs b/Distribution/Client/CmdTest.hs --- a/Distribution/Client/CmdTest.hs +++ b/Distribution/Client/CmdTest.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: test -- @@ -18,8 +17,7 @@ import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags - , applyFlagDefaults ) + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -80,7 +78,7 @@ -- testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO () -testAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, haddockFlags)) +testAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig @@ -111,7 +109,7 @@ TargetActionTest targets elaboratedPlan - return elaboratedPlan' + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx @@ -130,7 +128,7 @@ -- For the @test@ command we select all buildable test-suites, -- or fail if there are no test-suites or no buildable test-suites. -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -165,17 +163,20 @@ -- For the @test@ command we just need to check it is a test-suite, in addition -- to the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget@WholeComponent t +selectComponentTarget subtarget@WholeComponent t | CTestName _ <- availableTargetComponentName t = either (Left . TargetProblemCommon) return $ - selectComponentTargetBasic pkgid cname subtarget t + selectComponentTargetBasic subtarget t | otherwise - = Left (TargetProblemComponentNotTest pkgid cname) + = Left (TargetProblemComponentNotTest (availableTargetPackageId t) + (availableTargetComponentName t)) -selectComponentTarget pkgid cname subtarget _ - = Left (TargetProblemIsSubComponent pkgid cname subtarget) +selectComponentTarget subtarget t + = Left (TargetProblemIsSubComponent (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @test@ command. @@ -184,13 +185,13 @@ TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector -- | The 'TargetSelector' matches targets but no test-suites - | TargetProblemNoTests (TargetSelector PackageId) + | TargetProblemNoTests TargetSelector -- | The 'TargetSelector' refers to a component that is not a test-suite | TargetProblemComponentNotTest PackageId ComponentName @@ -225,10 +226,6 @@ ++ renderTargetSelector targetSelector ++ "." _ -> renderTargetProblemNoTargets "test" targetSelector - where - targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter - targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter - targetSelectorFilter (TargetComponent _ _ _) = Nothing renderTargetProblem (TargetProblemComponentNotTest pkgid cname) = "The test command is for running test suites, but the target '" diff --git a/Distribution/Client/CmdUpdate.hs b/Distribution/Client/CmdUpdate.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdUpdate.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns, + TupleSections #-} + +-- | cabal-install CLI command: update +-- +module Distribution.Client.CmdUpdate ( + updateCommand, + updateAction, + ) where + +import Distribution.Client.Compat.Directory + ( setModificationTime ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectConfig + ( ProjectConfig(..) + , projectConfigWithSolverRepoContext ) +import Distribution.Client.Types + ( Repo(..), RemoteRepo(..), isRepoRemote ) +import Distribution.Client.HttpUtils + ( DownloadResult(..) ) +import Distribution.Client.FetchUtils + ( downloadIndex ) +import Distribution.Client.JobControl + ( newParallelJobControl, spawnJob, collectJob ) +import Distribution.Client.Setup + ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags + , UpdateFlags, defaultUpdateFlags + , RepoContext(..) ) +import Distribution.Simple.Setup + ( HaddockFlags, fromFlagOrDefault ) +import Distribution.Simple.Utils + ( die', notice, wrapText, writeFileAtomic, noticeNoWrap, intercalate ) +import Distribution.Verbosity + ( Verbosity, normal, lessVerbose ) +import Distribution.Client.IndexUtils.Timestamp +import Distribution.Client.IndexUtils + ( updateRepoIndexCache, Index(..), writeIndexTimestamp + , currentIndexTimestamp, indexBaseName ) +import Distribution.Text + ( Text(..), display, simpleParse ) + +import Data.Maybe (fromJust) +import qualified Distribution.Compat.ReadP as ReadP +import qualified Text.PrettyPrint as Disp + +import Control.Monad (unless, when) +import qualified Data.ByteString.Lazy as BS +import Distribution.Client.GZipUtils (maybeDecompress) +import System.FilePath ((<.>), dropExtension) +import Data.Time (getCurrentTime) +import Distribution.Simple.Command + ( CommandUI(..), usageAlternatives ) +import qualified Distribution.Client.Setup as Client + +import qualified Hackage.Security.Client as Sec + +updateCommand :: CommandUI ( ConfigFlags, ConfigExFlags + , InstallFlags, HaddockFlags ) +updateCommand = Client.installCommand { + commandName = "new-update", + commandSynopsis = "Updates list of known packages.", + commandUsage = usageAlternatives "new-update" [ "[FLAGS] [REPOS]" ], + commandDescription = Just $ \_ -> wrapText $ + "For all known remote repositories, download the package list.", + commandNotes = Just $ \pname -> + "REPO has the format [,] where index-state follows\n" + ++ "the same format and syntax that is supported by the --index-state flag.\n\n" + ++ "Examples:\n" + ++ " " ++ pname ++ " new-update\n" + ++ " Download the package list for all known remote repositories.\n\n" + ++ " " ++ pname ++ " new-update hackage.haskell.org,@1474732068\n" + ++ " " ++ pname ++ " new-update hackage.haskell.org,2016-09-24T17:47:48Z\n" + ++ " " ++ pname ++ " new-update hackage.haskell.org,HEAD\n" + ++ " " ++ pname ++ " new-update hackage.haskell.org\n" + ++ " Download hackage.haskell.org at a specific index state.\n\n" + ++ " " ++ pname ++ " new update hackage.haskell.org head.hackage\n" + ++ " Download hackage.haskell.org and head.hackage\n" + ++ " head.hackage must be a known repo-id. E.g. from\n" + ++ " your cabal.project(.local) file.\n\n" + ++ "Note: this command is part of the new project-based system (aka " + ++ "nix-style\nlocal builds). These features are currently in beta. " + ++ "Please see\n" + ++ "http://cabal.readthedocs.io/en/latest/nix-local-build-overview.html " + ++ "for\ndetails and advice on what you can expect to work. If you " + ++ "encounter problems\nplease file issues at " + ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " + ++ "to get involved and help with testing, fixing bugs etc then\nthat " + ++ "is very much appreciated.\n" + } + +data UpdateRequest = UpdateRequest + { _updateRequestRepoName :: String + , _updateRequestRepoState :: IndexState + } deriving (Show) + +instance Text UpdateRequest where + disp (UpdateRequest n s) = Disp.text n Disp.<> Disp.char ',' Disp.<> disp s + parse = parseWithState ReadP.+++ parseHEAD + where parseWithState = do + name <- ReadP.many1 (ReadP.satisfy (\c -> c /= ',')) + _ <- ReadP.char ',' + state <- parse + return (UpdateRequest name state) + parseHEAD = do + name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof + return (UpdateRequest name IndexStateHead) + +updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> GlobalFlags -> IO () +updateAction (configFlags, configExFlags, installFlags, haddockFlags) + extraArgs globalFlags = do + + ProjectBaseContext { + projectConfig + } <- establishProjectBaseContext verbosity cliConfig + + projectConfigWithSolverRepoContext verbosity + (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig) + $ \repoCtxt -> do + let repos = filter isRepoRemote $ repoContextRepos repoCtxt + repoName = remoteRepoName . repoRemote + parseArg :: String -> IO UpdateRequest + parseArg s = case simpleParse s of + Just r -> return r + Nothing -> die' verbosity $ + "'new-update' unable to parse repo: \"" ++ s ++ "\"" + updateRepoRequests <- mapM parseArg extraArgs + + unless (null updateRepoRequests) $ do + let remoteRepoNames = map repoName repos + unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests + , not (r `elem` remoteRepoNames)] + unless (null unknownRepos) $ + die' verbosity $ "'new-update' repo(s): \"" + ++ intercalate "\", \"" unknownRepos + ++ "\" can not be found in known remote repo(s): " + ++ intercalate ", " remoteRepoNames + + let reposToUpdate :: [(Repo, IndexState)] + reposToUpdate = case updateRepoRequests of + -- If we are not given any specific repository, update all + -- repositories to HEAD. + [] -> map (,IndexStateHead) repos + updateRequests -> let repoMap = [(repoName r, r) | r <- repos] + lookup' k = fromJust (lookup k repoMap) + in [ (lookup' name, state) + | (UpdateRequest name state) <- updateRequests ] + + case reposToUpdate of + [] -> return () + [(remoteRepo, _)] -> + notice verbosity $ "Downloading the latest package list from " + ++ repoName remoteRepo + _ -> notice verbosity . unlines + $ "Downloading the latest package lists from: " + : map (("- " ++) . repoName . fst) reposToUpdate + + jobCtrl <- newParallelJobControl (length reposToUpdate) + mapM_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt) + reposToUpdate + mapM_ (\_ -> collectJob jobCtrl) reposToUpdate + + where + verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + cliConfig = commandLineFlagsToProjectConfig + globalFlags configFlags configExFlags + installFlags haddockFlags + +updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) + -> IO () +updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do + transport <- repoContextGetTransport repoCtxt + case repo of + RepoLocal{..} -> return () + RepoRemote{..} -> do + downloadResult <- downloadIndex transport verbosity + repoRemote repoLocalDir + case downloadResult of + FileAlreadyInCache -> + setModificationTime (indexBaseName repo <.> "tar") + =<< getCurrentTime + FileDownloaded indexPath -> do + writeFileAtomic (dropExtension indexPath) . maybeDecompress + =<< BS.readFile indexPath + updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) + RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do + let index = RepoIndex repoCtxt repo + -- NB: This may be a nullTimestamp if we've never updated before + current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo + -- NB: always update the timestamp, even if we didn't actually + -- download anything + writeIndexTimestamp index indexState + ce <- if repoContextIgnoreExpiry repoCtxt + then Just `fmap` getCurrentTime + else return Nothing + updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce + -- Update cabal's internal index as well so that it's not out of sync + -- (If all access to the cache goes through hackage-security this can go) + case updated of + Sec.NoUpdates -> + setModificationTime (indexBaseName repo <.> "tar") + =<< getCurrentTime + Sec.HasUpdates -> + updateRepoIndexCache verbosity index + -- TODO: This will print multiple times if there are multiple + -- repositories: main problem is we don't have a way of updating + -- a specific repo. Once we implement that, update this. + when (current_ts /= nullTimestamp) $ + noticeNoWrap verbosity $ + "To revert to previous state run:\n" ++ + " cabal new-update '" ++ remoteRepoName (repoRemote repo) + ++ "," ++ display current_ts ++ "'\n" diff --git a/Distribution/Client/Compat/Directory.hs b/Distribution/Client/Compat/Directory.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Compat/Directory.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} +module Distribution.Client.Compat.Directory (setModificationTime) where + +#if MIN_VERSION_directory(1,2,3) +import System.Directory (setModificationTime) +#else + +import Data.Time.Clock (UTCTime) + +setModificationTime :: FilePath -> UTCTime -> IO () +setModificationTime _fp _t = return () + +#endif diff --git a/Distribution/Client/Compat/FileLock.hsc b/Distribution/Client/Compat/FileLock.hsc --- a/Distribution/Client/Compat/FileLock.hsc +++ b/Distribution/Client/Compat/FileLock.hsc @@ -74,17 +74,14 @@ #endif /* !defined(solaris2_HOST_OS) */ -#endif /* MIN_VERSION_base */ - -#if !(MIN_VERSION_base(4,10,0)) - -- | Exception thrown by 'hLock' on non-Windows platforms that don't support -- 'flock'. data FileLockingNotSupported = FileLockingNotSupported deriving (Typeable, Show) instance Exception FileLockingNotSupported + -- | Indicates a mode in which a file should be locked. data LockMode = SharedLock | ExclusiveLock diff --git a/Distribution/Client/Compat/FilePerms.hs b/Distribution/Client/Compat/FilePerms.hs --- a/Distribution/Client/Compat/FilePerms.hs +++ b/Distribution/Client/Compat/FilePerms.hs @@ -12,9 +12,8 @@ import System.Posix.Internals ( c_chmod ) import Foreign.C - ( withCString ) -import Foreign.C - ( throwErrnoPathIfMinus1_ ) + ( withCString + , throwErrnoPathIfMinus1_ ) #else import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN) #endif /* mingw32_HOST_OS */ diff --git a/Distribution/Client/Compat/Semaphore.hs b/Distribution/Client/Compat/Semaphore.hs --- a/Distribution/Client/Compat/Semaphore.hs +++ b/Distribution/Client/Compat/Semaphore.hs @@ -10,7 +10,7 @@ import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry, writeTVar) import Control.Exception (mask_, onException) -import Control.Monad (join, when) +import Control.Monad (join, unless) import Data.Typeable (Typeable) -- | 'QSem' is a quantity semaphore in which the resource is aqcuired @@ -57,7 +57,7 @@ flip onException (wake s t) $ atomically $ do b <- readTVar t - when (not b) retry + unless b retry wake :: QSem -> TVar Bool -> IO () diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -45,7 +45,9 @@ ) where import Distribution.Client.Types - ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo ) + ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo + , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps + ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Setup @@ -62,7 +64,6 @@ ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags - , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , HaddockFlags(..), haddockOptions, defaultHaddockFlags , installDirsOptions, optionDistPref , programDbPaths', programDbOptions @@ -100,7 +101,7 @@ import Distribution.Solver.Types.ConstraintSource import Data.List - ( partition, find, foldl' ) + ( partition, find, foldl', nubBy ) import Data.Maybe ( fromMaybe ) import Control.Monad @@ -135,8 +136,6 @@ import qualified Data.Map as M import Data.Function ( on ) -import Data.List - ( nubBy ) import GHC.Generics ( Generic ) -- @@ -205,6 +204,12 @@ in case b' of [] -> a' _ -> b' + lastNonMempty' :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a + lastNonMempty' field subfield = + let a' = subfield . field $ a + b' = subfield . field $ b + in if b' == mempty then a' else b' + lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a) -> NubList a lastNonEmptyNL' field subfield = @@ -229,7 +234,8 @@ globalIgnoreExpiry = combine globalIgnoreExpiry, globalHttpTransport = combine globalHttpTransport, globalNix = combine globalNix, - globalStoreDir = combine globalStoreDir + globalStoreDir = combine globalStoreDir, + globalProgPathExtra = lastNonEmptyNL globalProgPathExtra } where combine = combine' savedGlobalFlags @@ -239,6 +245,7 @@ installDocumentation = combine installDocumentation, installHaddockIndex = combine installHaddockIndex, installDryRun = combine installDryRun, + installDest = combine installDest, installMaxBackjumps = combine installMaxBackjumps, installReorderGoals = combine installReorderGoals, installCountConflicts = combine installCountConflicts, @@ -287,6 +294,7 @@ configProfLib = combine configProfLib, configProf = combine configProf, configSharedLib = combine configSharedLib, + configStaticLib = combine configStaticLib, configDynExe = combine configDynExe, configProfExe = combine configProfExe, configProfDetail = combine configProfDetail, @@ -318,6 +326,7 @@ -- TODO: NubListify configPackageDBs = lastNonEmpty configPackageDBs, configGHCiLib = combine configGHCiLib, + configSplitSections = combine configSplitSections, configSplitObjs = combine configSplitObjs, configStripExes = combine configStripExes, configStripLibs = combine configStripLibs, @@ -326,7 +335,7 @@ -- TODO: NubListify configDependencies = lastNonEmpty configDependencies, -- TODO: NubListify - configConfigurationsFlags = lastNonEmpty configConfigurationsFlags, + configConfigurationsFlags = lastNonMempty configConfigurationsFlags, configTests = combine configTests, configBenchmarks = combine configBenchmarks, configCoverage = combine configCoverage, @@ -334,15 +343,13 @@ configExactConfiguration = combine configExactConfiguration, configFlagError = combine configFlagError, configRelocatable = combine configRelocatable, - configAllowOlder = combineMonoid savedConfigureFlags - configAllowOlder, - configAllowNewer = combineMonoid savedConfigureFlags - configAllowNewer + configUseResponseFiles = combine configUseResponseFiles } where combine = combine' savedConfigureFlags lastNonEmpty = lastNonEmpty' savedConfigureFlags lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags + lastNonMempty = lastNonMempty' savedConfigureFlags combinedSavedConfigureExFlags = ConfigExFlags { configCabalVersion = combine configCabalVersion, @@ -350,7 +357,9 @@ configExConstraints = lastNonEmpty configExConstraints, -- TODO: NubListify configPreferences = lastNonEmpty configPreferences, - configSolver = combine configSolver + configSolver = combine configSolver, + configAllowNewer = combineMonoid savedConfigureExFlags configAllowNewer, + configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder } where combine = combine' savedConfigureExFlags @@ -398,12 +407,13 @@ haddockForeignLibs = combine haddockForeignLibs, haddockInternal = combine haddockInternal, haddockCss = combine haddockCss, - haddockHscolour = combine haddockHscolour, + haddockLinkedSource = combine haddockLinkedSource, haddockHscolourCss = combine haddockHscolourCss, haddockContents = combine haddockContents, haddockDistPref = combine haddockDistPref, haddockKeepTempFiles = combine haddockKeepTempFiles, - haddockVerbosity = combine haddockVerbosity + haddockVerbosity = combine haddockVerbosity, + haddockCabalFilePath = combine haddockCabalFilePath } where combine = combine' savedHaddockFlags @@ -422,6 +432,7 @@ baseSavedConfig :: IO SavedConfig baseSavedConfig = do userPrefix <- defaultCabalDir + cacheDir <- defaultCacheDir logsDir <- defaultLogsDir worldFile <- defaultWorldFile return mempty { @@ -434,6 +445,7 @@ prefix = toFlag (toPathTemplate userPrefix) }, savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, globalLogsDir = toFlag logsDir, globalWorldFile = toFlag worldFile } @@ -451,6 +463,7 @@ logsDir <- defaultLogsDir worldFile <- defaultWorldFile extraPath <- defaultExtraPath + symlinkPath <- defaultSymlinkPath return mempty { savedGlobalFlags = mempty { globalCacheDir = toFlag cacheDir, @@ -463,7 +476,8 @@ savedInstallFlags = mempty { installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], installBuildReports= toFlag AnonymousReports, - installNumJobs = toFlag Nothing + installNumJobs = toFlag Nothing, + installSymlinkBinDir = toFlag symlinkPath } } @@ -498,6 +512,11 @@ dir <- defaultCabalDir return [dir "bin"] +defaultSymlinkPath :: IO FilePath +defaultSymlinkPath = do + dir <- defaultCabalDir + return (dir "bin") + defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor @@ -610,7 +629,7 @@ Nothing -> do notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "." notice verbosity $ "Config file " ++ configFile ++ " not found." - createDefaultConfigFile verbosity configFile + createDefaultConfigFile verbosity [] configFile Just (ParseOk ws conf) -> do unless (null ws) $ warn verbosity $ unlines (map (showPWarning configFile) ws) @@ -659,12 +678,13 @@ then return Nothing else ioError ioe -createDefaultConfigFile :: Verbosity -> FilePath -> IO SavedConfig -createDefaultConfigFile verbosity filePath = do +createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig +createDefaultConfigFile verbosity extraLines filePath = do commentConf <- commentSavedConfig initialConf <- initialSavedConfig + extraConf <- parseExtraLines verbosity extraLines notice verbosity $ "Writing default configuration to " ++ filePath - writeConfigFile filePath commentConf initialConf + writeConfigFile filePath commentConf (initialConf `mappend` extraConf) return initialConf writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () @@ -705,11 +725,12 @@ globalRemoteRepos = toNubList [defaultRemoteRepo] }, savedInstallFlags = defaultInstallFlags, - savedConfigureExFlags = defaultConfigExFlags, + savedConfigureExFlags = defaultConfigExFlags { + configAllowNewer = Just (AllowNewer mempty), + configAllowOlder = Just (AllowOlder mempty) + }, savedConfigureFlags = (defaultConfigFlags defaultProgramDb) { - configUserInstall = toFlag defaultUserInstall, - configAllowNewer = Just (AllowNewer RelaxDepsNone), - configAllowOlder = Just (AllowOlder RelaxDepsNone) + configUserInstall = toFlag defaultUserInstall }, savedUserInstallDirs = fmap toFlag userInstallDirs, savedGlobalInstallDirs = fmap toFlag globalInstallDirs, @@ -752,16 +773,7 @@ [simpleField "compiler" (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) configHcFlavor (\v flags -> flags { configHcFlavor = v }) - ,let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse - parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in - simpleField "allow-older" - (showRelaxDeps . fmap unAllowOlder) parseAllowOlder - configAllowOlder (\v flags -> flags { configAllowOlder = v }) - ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse - parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in - simpleField "allow-newer" - (showRelaxDeps . fmap unAllowNewer) parseAllowNewer - configAllowNewer (\v flags -> flags { configAllowNewer = v }) + -- TODO: The following is a temporary fix. The "optimization" -- and "debug-info" fields are OptArg, and viewAsFieldDescr -- fails on that. Instead of a hand-written hackaged parser @@ -818,7 +830,18 @@ ++ toSavedConfig liftConfigExFlag (configureExOptions ParseArgs src) - [] [] + [] + [let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse + parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in + simpleField "allow-older" + (showRelaxDeps . fmap unAllowOlder) parseAllowOlder + configAllowOlder (\v flags -> flags { configAllowOlder = v }) + ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse + parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in + simpleField "allow-newer" + (showRelaxDeps . fmap unAllowNewer) parseAllowNewer + configAllowNewer (\v flags -> flags { configAllowNewer = v }) + ] ++ toSavedConfig liftInstallFlag (installOptions ParseArgs) @@ -861,12 +884,12 @@ optional = Parse.option mempty . fmap toFlag - showRelaxDeps Nothing = mempty - showRelaxDeps (Just RelaxDepsNone) = Disp.text "False" - showRelaxDeps (Just _) = Disp.text "True" + showRelaxDeps Nothing = mempty + showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True" + | otherwise = Disp.text "False" toRelaxDeps True = RelaxDepsAll - toRelaxDeps False = RelaxDepsNone + toRelaxDeps False = mempty -- TODO: next step, make the deprecated fields elicit a warning. @@ -961,7 +984,9 @@ return config { savedGlobalFlags = (savedGlobalFlags config) { - globalRemoteRepos = toNubList remoteRepoSections + globalRemoteRepos = toNubList remoteRepoSections, + -- the global extra prog path comes from the configure flag prog path + globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) }, savedConfigureFlags = (savedConfigureFlags config) { configProgramPaths = paths, @@ -1140,16 +1165,30 @@ map viewAsFieldDescr $ programDbOptions defaultProgramDb ParseArgs id (++) +parseExtraLines :: Verbosity -> [String] -> IO SavedConfig +parseExtraLines verbosity extraLines = + case parseConfig (ConstraintSourceMainConfig "additional lines") + mempty (unlines extraLines) of + ParseFailed err -> + let (line, msg) = locatedErrorMsg err + in die' verbosity $ + "Error parsing additional config lines\n" + ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg + ParseOk [] r -> return r + ParseOk ws _ -> die' verbosity $ + unlines (map (showPWarning "Error parsing additional config lines") ws) + -- | Get the differences (as a pseudo code diff) between the user's -- '~/.cabal/config' and the one that cabal would generate if it didn't exist. -userConfigDiff :: GlobalFlags -> IO [String] -userConfigDiff globalFlags = do +userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String] +userConfigDiff verbosity globalFlags extraLines = do userConfig <- loadRawConfig normal (globalConfigFile globalFlags) + extraConfig <- parseExtraLines verbosity extraLines testConfig <- initialSavedConfig return $ reverse . foldl' createDiff [] . M.toList $ M.unionWith combine (M.fromList . map justFst $ filterShow testConfig) - (M.fromList . map justSnd $ filterShow userConfig) + (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) where justFst (a, b) = (a, (Just b, Nothing)) justSnd (a, b) = (a, (Nothing, Just b)) @@ -1170,7 +1209,7 @@ filterShow :: SavedConfig -> [(String, String)] filterShow cfg = map keyValueSplit - . filter (\s -> not (null s) && any (== ':') s) + . filter (\s -> not (null s) && ':' `elem` s) . map nonComment . lines $ showConfig cfg @@ -1187,9 +1226,10 @@ -- | Update the user's ~/.cabal/config' keeping the user's customizations. -userConfigUpdate :: Verbosity -> GlobalFlags -> IO () -userConfigUpdate verbosity globalFlags = do +userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () +userConfigUpdate verbosity globalFlags extraLines = do userConfig <- loadRawConfig normal (globalConfigFile globalFlags) + extraConfig <- parseExtraLines verbosity extraLines newConfig <- initialSavedConfig commentConf <- commentSavedConfig cabalFile <- getConfigFilePath $ globalConfigFile globalFlags @@ -1197,4 +1237,4 @@ notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." renameFile cabalFile backup notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." - writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig) + writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig `mappend` extraConfig) diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -38,7 +38,6 @@ ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Targets ( userToPackageConstraint, userConstraintPackageName ) -import Distribution.Package (PackageId) import Distribution.Client.JobControl (Lock) import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -57,33 +56,25 @@ import Distribution.Simple.Program (ProgramDb) import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags ) import Distribution.Simple.Setup - ( ConfigFlags(..), AllowNewer(..), AllowOlder(..), RelaxDeps(..) + ( ConfigFlags(..) , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex, lookupPackageName ) -import Distribution.Simple.Utils - ( defaultPackageDesc ) import Distribution.Package - ( Package(..), packageName ) + ( Package(..), packageName, PackageId ) import Distribution.Types.Dependency ( Dependency(..), thisPackageVersion ) import qualified Distribution.PackageDescription as PkgDesc -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) -#else -import Distribution.PackageDescription.Parse - ( readGenericPackageDescription ) -#endif import Distribution.PackageDescription.Configuration ( finalizePD ) import Distribution.Version ( Version, mkVersion, anyVersion, thisVersion , VersionRange, orLaterVersion ) import Distribution.Simple.Utils as Utils - ( warn, notice, debug, die' ) -import Distribution.Simple.Setup - ( isRelaxDeps ) + ( warn, notice, debug, die' + , defaultPackageDesc ) import Distribution.System ( Platform ) import Distribution.Text ( display ) @@ -94,16 +85,16 @@ -- | Choose the Cabal version such that the setup scripts compiled against this -- version will support the given command-line flags. -chooseCabalVersion :: ConfigFlags -> Maybe Version -> VersionRange -chooseCabalVersion configFlags maybeVersion = +chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange +chooseCabalVersion configExFlags maybeVersion = maybe defaultVersionRange thisVersion maybeVersion where -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed -- for '--allow-newer' to work. allowNewer = isRelaxDeps - (maybe RelaxDepsNone unAllowNewer $ configAllowNewer configFlags) + (maybe mempty unAllowNewer $ configAllowNewer configExFlags) allowOlder = isRelaxDeps - (maybe RelaxDepsNone unAllowOlder $ configAllowOlder configFlags) + (maybe mempty unAllowOlder $ configAllowOlder configExFlags) defaultVersionRange = if allowOlder || allowNewer then orLaterVersion (mkVersion [1,19,2]) @@ -173,7 +164,7 @@ (useDistPref defaultSetupScriptOptions) (configDistPref configFlags)) (chooseCabalVersion - configFlags + configExFlags (flagToMaybe (configCabalVersion configExFlags))) Nothing False @@ -213,6 +204,7 @@ , useLoggingHandle = Nothing , useWorkingDir = Nothing , useExtraPathEnv = [] + , useExtraEnvOverrides = [] , setupCacheLock = lock , useWin32CleanHack = False , forceExternalSetupMethod = forceExternal @@ -323,9 +315,9 @@ resolverParams = removeLowerBounds - (fromMaybe (AllowOlder RelaxDepsNone) $ configAllowOlder configFlags) + (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags) . removeUpperBounds - (fromMaybe (AllowNewer RelaxDepsNone) $ configAllowNewer configFlags) + (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags) . addPreferences -- preferences from the config file or command line diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -61,23 +61,27 @@ removeUpperBounds, addDefaultSetupDependencies, addSetupCabalMinVersionConstraint, + addSetupCabalMaxVersionConstraint, ) where import Distribution.Solver.Modular - ( modularResolver, SolverConfig(..) ) + ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Types ( SourcePackageDb(SourcePackageDb) - , UnresolvedPkgLoc, UnresolvedSourcePackage ) + , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints + , UnresolvedPkgLoc, UnresolvedSourcePackage + , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..) + , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps + ) import Distribution.Client.Dependency.Types ( PreSolver(..), Solver(..) , PackagesPreferenceDefault(..) ) import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..) ) -import Distribution.Client.Targets import Distribution.Package ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId , Package(..), packageName, packageVersion ) @@ -88,26 +92,21 @@ ( finalizePD ) import Distribution.Client.PackageUtils ( externalBuildDepends ) -import Distribution.Version - ( Version, mkVersion - , VersionRange, anyVersion, thisVersion, orLaterVersion, withinRange - , simplifyVersionRange, removeLowerBound, removeUpperBound ) import Distribution.Compiler ( CompilerInfo(..) ) import Distribution.System ( Platform ) import Distribution.Client.Utils - ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) + ( duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils ( comparing ) -import Distribution.Simple.Configure - ( relaxPackageDeps ) import Distribution.Simple.Setup - ( asBool, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) + ( asBool ) import Distribution.Text ( display ) import Distribution.Verbosity ( normal, Verbosity ) +import Distribution.Version import qualified Distribution.Compat.Graph as Graph import Distribution.Solver.Types.ComponentDeps (ComponentDeps) @@ -133,7 +132,7 @@ import Data.List ( foldl', sort, sortBy, nubBy, maximumBy, intercalate, nub ) import Data.Function (on) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) @@ -426,24 +425,18 @@ -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. -- removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams -removeUpperBounds (AllowNewer RelaxDepsNone) params = params -removeUpperBounds (AllowNewer allowNewer) params = - params { - depResolverSourcePkgIndex = sourcePkgIndex' - } - where - sourcePkgIndex' = fmap relaxDeps $ depResolverSourcePkgIndex params - - relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage - relaxDeps srcPkg = srcPkg { - packageDescription = relaxPackageDeps removeUpperBound allowNewer - (packageDescription srcPkg) - } +removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps -- | Dual of 'removeUpperBounds' removeLowerBounds :: AllowOlder -> DepResolverParams -> DepResolverParams -removeLowerBounds (AllowOlder RelaxDepsNone) params = params -removeLowerBounds (AllowOlder allowNewer) params = +removeLowerBounds (AllowOlder relDeps) = removeBounds RelaxLower relDeps + +data RelaxKind = RelaxLower | RelaxUpper + +-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds' +removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams +removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation +removeBounds relKind relDeps params = params { depResolverSourcePkgIndex = sourcePkgIndex' } @@ -452,10 +445,65 @@ relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage relaxDeps srcPkg = srcPkg { - packageDescription = relaxPackageDeps removeLowerBound allowNewer + packageDescription = relaxPackageDeps relKind relDeps (packageDescription srcPkg) } +-- | Relax the dependencies of this package if needed. +-- +-- Helper function used by 'removeBounds' +relaxPackageDeps :: RelaxKind + -> RelaxDeps + -> PD.GenericPackageDescription -> PD.GenericPackageDescription +relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds' +relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd + where + relaxAll :: Dependency -> Dependency + relaxAll (Dependency pkgName verRange) = + Dependency pkgName (removeBound relKind RelaxDepModNone verRange) + +relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd = + PD.transformAllBuildDepends relaxSome gpd + where + thisPkgName = packageName gpd + thisPkgId = packageId gpd + depsToRelax = Map.fromList $ mapMaybe f depsToRelax0 + + f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod) + f (RelaxedDep scope rdm p) = case scope of + RelaxDepScopeAll -> Just (p,rdm) + RelaxDepScopePackage p0 + | p0 == thisPkgName -> Just (p,rdm) + | otherwise -> Nothing + RelaxDepScopePackageId p0 + | p0 == thisPkgId -> Just (p,rdm) + | otherwise -> Nothing + + relaxSome :: Dependency -> Dependency + relaxSome d@(Dependency depName verRange) + | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax = + -- a '*'-subject acts absorbing, for consistency with + -- the 'Semigroup RelaxDeps' instance + Dependency depName (removeBound relKind relMod verRange) + | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax = + Dependency depName (removeBound relKind relMod verRange) + | otherwise = d -- no-op + +-- | Internal helper for 'relaxPackageDeps' +removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange +removeBound RelaxLower RelaxDepModNone = removeLowerBound +removeBound RelaxUpper RelaxDepModNone = removeUpperBound +removeBound relKind RelaxDepModCaret = hyloVersionRange embed projectVersionRange + where + embed (MajorBoundVersionF v) = caretTransformation v (majorUpperBound v) + embed vr = embedVersionRange vr + + -- This function is the interesting part as it defines the meaning + -- of 'RelaxDepModCaret', i.e. to transform only @^>=@ constraints; + caretTransformation l u = case relKind of + RelaxUpper -> orLaterVersion l -- rewrite @^>= x.y.z@ into @>= x.y.z@ + RelaxLower -> earlierVersion u -- rewrite @^>= x.y.z@ into @< x.(y+1)@ + -- | Supply defaults for packages without explicit Setup dependencies -- -- Note: It's important to apply 'addDefaultSetupDepends' after @@ -478,16 +526,18 @@ PD.setupBuildInfo = case PD.setupBuildInfo pkgdesc of Just sbi -> Just sbi - Nothing -> case defaultSetupDeps srcpkg of + Nothing -> case defaultSetupDeps srcpkg of Nothing -> Nothing - Just deps -> Just PD.SetupBuildInfo { - PD.defaultSetupDepends = True, - PD.setupDepends = deps - } + Just deps | isCustom -> Just PD.SetupBuildInfo { + PD.defaultSetupDepends = True, + PD.setupDepends = deps + } + | otherwise -> Nothing } } } where + isCustom = PD.buildType pkgdesc == PD.Custom gpkgdesc = packageDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc @@ -506,7 +556,22 @@ where cabalPkgname = mkPackageName "Cabal" +-- | Variant of 'addSetupCabalMinVersionConstraint' which sets an +-- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'. +-- +addSetupCabalMaxVersionConstraint :: Version + -> DepResolverParams -> DepResolverParams +addSetupCabalMaxVersionConstraint maxVersion = + addConstraints + [ LabeledPackageConstraint + (PackageConstraint (ScopeAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ earlierVersion maxVersion)) + ConstraintSetupCabalMaxVersion + ] + where + cabalPkgname = mkPackageName "Cabal" + upgradeDependencies :: DepResolverParams -> DepResolverParams upgradeDependencies = setPreferenceDefault PreferAllLatest @@ -572,7 +637,7 @@ where gpkgdesc = packageDescription srcpkg pkgdesc = PD.packageDescription gpkgdesc - bt = fromMaybe PD.Custom (PD.buildType pkgdesc) + bt = PD.buildType pkgdesc affected = bt == PD.Custom && hasBuildableFalse gpkgdesc -- Does this package contain any components with non-empty 'build-depends' @@ -670,7 +735,7 @@ $ runSolver solver (SolverConfig reordGoals cntConflicts indGoals noReinstalls shadowing strFlags allowBootLibs maxBkjumps enableBj - solveExes order verbosity) + solveExes order verbosity (PruneAfterFirstSuccess False)) platform comp installedPkgIndex sourcePkgIndex pkgConfigDB preferences constraints targets where @@ -842,7 +907,8 @@ -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') = - [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] + [ DuplicateFlag flag + | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] ++ [ DuplicateDeps pkgs @@ -859,7 +925,7 @@ mergedFlags = mergeBy compare (sort $ map PD.flagName (PD.genPackageFlags (packageDescription pkg))) - (sort $ map fst specifiedFlags) + (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO packageSatisfiesDependency (PackageIdentifier name version) diff --git a/Distribution/Client/DistDirLayout.hs b/Distribution/Client/DistDirLayout.hs --- a/Distribution/Client/DistDirLayout.hs +++ b/Distribution/Client/DistDirLayout.hs @@ -2,7 +2,7 @@ -- | -- --- The layout of the .\/dist\/ directory where cabal keeps all of it's state +-- The layout of the .\/dist\/ directory where cabal keeps all of its state -- and build artifacts. -- module Distribution.Client.DistDirLayout ( @@ -185,10 +185,14 @@ display (distParamPlatform params) display (distParamCompilerId params) display (distParamPackageId params) - (case fmap componentNameString (distParamComponentName params) of - Nothing -> "" - Just Nothing -> "" - Just (Just name) -> "c" display name) + (case distParamComponentName params of + Nothing -> "" + Just CLibName -> "" + Just (CSubLibName name) -> "l" display name + Just (CFLibName name) -> "f" display name + Just (CExeName name) -> "x" display name + Just (CTestName name) -> "t" display name + Just (CBenchName name) -> "b" display name) (case distParamOptimization params of NoOptimisation -> "noopt" NormalOptimisation -> "" diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -1,5 +1,4 @@ ------------------------------------------------------------------------------ --- | +------------------------------------------------------------------------------- | -- Module : Distribution.Client.Fetch -- Copyright : (c) David Himmelstrup 2005 -- Duncan Coutts 2011 @@ -25,6 +24,9 @@ import Distribution.Client.Setup ( GlobalFlags(..), FetchFlags(..), RepoContext(..) ) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb ) import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage @@ -37,7 +39,7 @@ import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup - ( fromFlag ) + ( fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, debug ) import Distribution.System @@ -168,6 +170,13 @@ . setSolverVerbosity verbosity + . addConstraints + [ let pc = PackageConstraint + (scopeToplevel $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) + in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget + | pkgSpecifier <- pkgSpecifiers ] + -- Reinstall the targets given on the command line so that the dep -- resolver will decide that they need fetching, even if they're -- already installed. Since we want to get the source packages of @@ -178,6 +187,11 @@ includeDependencies = fromFlag (fetchDeps fetchFlags) logMsg message rest = debug verbosity message >> rest + + stanzas = [ TestStanzas | testsEnabled ] + ++ [ BenchStanzas | benchmarksEnabled ] + testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags + benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags reorderGoals = fromFlag (fetchReorderGoals fetchFlags) countConflicts = fromFlag (fetchCountConflicts fetchFlags) diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs --- a/Distribution/Client/FetchUtils.hs +++ b/Distribution/Client/FetchUtils.hs @@ -178,7 +178,7 @@ path = packageFile repo pkgid createDirectoryIfMissing True dir Sec.uncheckClientErrors $ do - info verbosity ("writing " ++ path) + info verbosity ("Writing " ++ path) Sec.downloadPackage' rep pkgid path return path diff --git a/Distribution/Client/GenBounds.hs b/Distribution/Client/GenBounds.hs --- a/Distribution/Client/GenBounds.hs +++ b/Distribution/Client/GenBounds.hs @@ -15,6 +15,9 @@ genBounds ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.Init ( incVersion ) import Distribution.Client.Freeze @@ -29,13 +32,8 @@ ( buildDepends ) import Distribution.PackageDescription.Configuration ( finalizePD ) -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) -#else -import Distribution.PackageDescription.Parse - ( readGenericPackageDescription ) -#endif import Distribution.Types.ComponentRequestedSpec ( defaultComponentRequestedSpec ) import Distribution.Types.Dependency @@ -118,7 +116,7 @@ gpd <- readGenericPackageDescription verbosity path -- NB: We don't enable tests or benchmarks, since often they -- don't really have useful bounds. - let epd = finalizePD [] defaultComponentRequestedSpec + let epd = finalizePD mempty defaultComponentRequestedSpec (const True) platform cinfo [] gpd case epd of Left _ -> putStrLn "finalizePD failed" @@ -143,7 +141,7 @@ let thePkgs = filter isNeeded pkgs let padTo = maximum $ map (length . unPackageName . packageName) pkgs - mapM_ (putStrLn . (++",") . showBounds padTo) thePkgs + traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs depName :: Dependency -> String depName (Dependency pn _) = unPackageName pn diff --git a/Distribution/Client/Get.hs b/Distribution/Client/Get.hs --- a/Distribution/Client/Get.hs +++ b/Distribution/Client/Get.hs @@ -23,7 +23,7 @@ import Distribution.Package ( PackageId, packageId, packageName ) import Distribution.Simple.Setup - ( Flag(..), fromFlag, fromFlagOrDefault ) + ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils ( notice, die', info, rawSystemExitCode, writeFileAtomic ) import Distribution.Verbosity @@ -39,7 +39,7 @@ import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackagesAtIndexState, IndexState(..) ) + ( getSourcePackagesAtIndexState ) import Distribution.Client.Compat.Process ( readProcessWithExitCode ) import Distribution.Compat.Exception @@ -82,8 +82,7 @@ unless useFork $ mapM_ (checkTarget verbosity) userTargets - let idxState = fromFlagOrDefault IndexStateHead $ - getIndexState getFlags + let idxState = flagToMaybe $ getIndexState getFlags sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState diff --git a/Distribution/Client/GlobalFlags.hs b/Distribution/Client/GlobalFlags.hs --- a/Distribution/Client/GlobalFlags.hs +++ b/Distribution/Client/GlobalFlags.hs @@ -69,7 +69,8 @@ globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates globalHttpTransport :: Flag String, globalNix :: Flag Bool, -- ^ Integrate with Nix - globalStoreDir :: Flag FilePath + globalStoreDir :: Flag FilePath, + globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) } deriving Generic defaultGlobalFlags :: GlobalFlags @@ -89,7 +90,8 @@ globalIgnoreExpiry = Flag False, globalHttpTransport = mempty, globalNix = Flag False, - globalStoreDir = mempty + globalStoreDir = mempty, + globalProgPathExtra = mempty } instance Monoid GlobalFlags where @@ -139,18 +141,20 @@ withRepoContext verbosity globalFlags = withRepoContext' verbosity - (fromNubList (globalRemoteRepos globalFlags)) - (fromNubList (globalLocalRepos globalFlags)) - (fromFlag (globalCacheDir globalFlags)) - (flagToMaybe (globalHttpTransport globalFlags)) - (flagToMaybe (globalIgnoreExpiry globalFlags)) + (fromNubList (globalRemoteRepos globalFlags)) + (fromNubList (globalLocalRepos globalFlags)) + (fromFlag (globalCacheDir globalFlags)) + (flagToMaybe (globalHttpTransport globalFlags)) + (flagToMaybe (globalIgnoreExpiry globalFlags)) + (fromNubList (globalProgPathExtra globalFlags)) withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] -> FilePath -> Maybe String -> Maybe Bool + -> [FilePath] -> (RepoContext -> IO a) -> IO a withRepoContext' verbosity remoteRepos localRepos - sharedCacheDir httpTransport ignoreExpiry = \callback -> do + sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do transportRef <- newMVar Nothing let httpLib = Sec.HTTP.transportAdapter verbosity @@ -178,7 +182,7 @@ modifyMVar transportRef $ \mTransport -> do transport <- case mTransport of Just tr -> return tr - Nothing -> configureTransport verbosity httpTransport + Nothing -> configureTransport verbosity extraPaths httpTransport return (Just transport, transport) withSecureRepo :: Map Repo SecureRepo diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -38,8 +38,7 @@ import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils ( die', info, warn, debug, notice, writeFileAtomic - , copyFileVerbose, withTempFile - , rawSystemStdInOut, toUTF8, fromUTF8, normaliseLineEndings ) + , copyFileVerbose, withTempFile ) import Distribution.Client.Utils ( withTempFileName ) import Distribution.Client.Types @@ -51,9 +50,9 @@ import qualified System.FilePath.Posix as FilePath.Posix ( splitDirectories ) import System.FilePath - ( (<.>) ) + ( (<.>), takeFileName, takeDirectory ) import System.Directory - ( doesFileExist, renameFile ) + ( doesFileExist, renameFile, canonicalizePath ) import System.IO ( withFile, IOMode(ReadMode), hGetContents, hClose ) import System.IO.Error @@ -61,16 +60,16 @@ import Distribution.Simple.Program ( Program, simpleProgram, ConfiguredProgram, programPath , ProgramInvocation(..), programInvocation + , ProgramSearchPathEntry(..) , getProgramInvocationOutput ) import Distribution.Simple.Program.Db ( ProgramDb, emptyProgramDb, addKnownPrograms , configureAllKnownPrograms - , requireProgram, lookupProgram ) + , requireProgram, lookupProgram + , modifyProgramSearchPath ) import Distribution.Simple.Program.Run - ( IOEncoding(..), getEffectiveEnvironment ) + ( getProgramInvocationOutputAndErrors ) import Numeric (showHex) -import System.Directory (canonicalizePath) -import System.FilePath (takeFileName, takeDirectory) import System.Random (randomRIO) import System.Exit (ExitCode(..)) @@ -267,18 +266,19 @@ , \_ -> Just plainHttpTransport ) ] -configureTransport :: Verbosity -> Maybe String -> IO HttpTransport +configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport -configureTransport verbosity (Just name) = +configureTransport verbosity extraPath (Just name) = -- the user secifically selected a transport by name so we'll try and -- configure that one case find (\(name',_,_,_) -> name' == name) supportedTransports of Just (_, mprog, _tls, mkTrans) -> do + let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb progdb <- case mprog of Nothing -> return emptyProgramDb - Just prog -> snd <$> requireProgram verbosity prog emptyProgramDb + Just prog -> snd <$> requireProgram verbosity prog baseProgDb -- ^^ if it fails, it'll fail here let Just transport = mkTrans progdb @@ -289,16 +289,17 @@ ++ intercalate ", " [ name' | (name', _, _, _ ) <- supportedTransports ] -configureTransport verbosity Nothing = do +configureTransport verbosity extraPath Nothing = do -- the user hasn't selected a transport, so we'll pick the first one we -- can configure successfully, provided that it supports tls -- for all the transports except plain-http we need to try and find -- their external executable + let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb progdb <- configureAllKnownPrograms verbosity $ addKnownPrograms [ prog | (_, Just prog, _, _) <- supportedTransports ] - emptyProgramDb + baseProgDb let availableTransports = [ (name, transport) @@ -422,7 +423,7 @@ -- wget doesn't support range requests. -- so, we not only ignore range request headers, -- but we also dispay a warning message when we see them. - let hasRangeHeader = any (\hdr -> isRangeHeader hdr) reqHeaders + let hasRangeHeader = any isRangeHeader reqHeaders warningMsg = "the 'wget' transport currently doesn't support" ++ " range requests, which wastes network bandwidth." ++ " To fix this, set 'http-transport' to 'curl' or" @@ -544,16 +545,37 @@ gethttp verbosity uri etag destPath reqHeaders = do resp <- runPowershellScript verbosity $ webclientScript - (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)) - [ "$wc.DownloadFile(" ++ escape (show uri) - ++ "," ++ escape destPath ++ ");" - , "Write-Host \"200\";" - , "Write-Host $wc.ResponseHeaders.Item(\"ETag\");" + (escape (show uri)) + (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create") + :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))) + [ "$response = $request.GetResponse()" + , "$responseStream = $response.GetResponseStream()" + , "$buffer = new-object byte[] 10KB" + , "$count = $responseStream.Read($buffer, 0, $buffer.length)" + , "while ($count -gt 0)" + , "{" + , " $targetStream.Write($buffer, 0, $count)" + , " $count = $responseStream.Read($buffer, 0, $buffer.length)" + , "}" + , "Write-Host ($response.StatusCode -as [int]);" + , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')" ] + [ "$targetStream.Flush()" + , "$targetStream.Close()" + , "$targetStream.Dispose()" + , "$responseStream.Dispose()" + ] parseResponse resp where - parseResponse x = case readMaybe . unlines . take 1 . lines $ trim x of - Just i -> return (i, Nothing) -- TODO extract real etag + parseResponse :: String -> IO (HttpCode, Maybe ETag) + parseResponse x = + case lines $ trim x of + (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x + (code: _) -> fmap (\c -> (c, Nothing )) $ parseCode code x + _ -> statusParseFail verbosity uri x + parseCode :: String -> String -> IO HttpCode + parseCode code x = case readMaybe code of + Just i -> return i Nothing -> statusParseFail verbosity uri x etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ] @@ -570,15 +592,19 @@ let contentHeader = Header HdrContentType ("multipart/form-data; boundary=" ++ boundary) resp <- runPowershellScript verbosity $ webclientScript + (escape (show uri)) (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth) (uploadFileAction "POST" uri fullPath) + uploadFileCleanup parseUploadResponse verbosity uri resp puthttpfile verbosity uri path auth headers = do fullPath <- canonicalizePath path resp <- runPowershellScript verbosity $ webclientScript + (escape (show uri)) (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth) (uploadFileAction "PUT" uri fullPath) + uploadFileCleanup parseUploadResponse verbosity uri resp runPowershellScript verbosity script = do @@ -590,6 +616,7 @@ , "-NoProfile", "-NonInteractive" , "-Command", "-" ] + debug verbosity script getProgramInvocationOutput verbosity (programInvocation prog args) { progInvokeInput = Just (script ++ "\nExit(0);") } @@ -600,31 +627,74 @@ extraHeaders = [Header HdrAccept "text/plain", useragentHeader] setupHeaders headers = - [ "$wc.Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");" + [ "$request." ++ addHeader name value | Header name value <- headers ] + where + addHeader header value + = case header of + HdrAccept -> "Accept = " ++ escape value + HdrUserAgent -> "UserAgent = " ++ escape value + HdrConnection -> "Connection = " ++ escape value + HdrContentLength -> "ContentLength = " ++ escape value + HdrContentType -> "ContentType = " ++ escape value + HdrDate -> "Date = " ++ escape value + HdrExpect -> "Expect = " ++ escape value + HdrHost -> "Host = " ++ escape value + HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value + HdrReferer -> "Referer = " ++ escape value + HdrTransferEncoding -> "TransferEncoding = " ++ escape value + HdrRange -> let (start, _:end) = + if "bytes=" `isPrefixOf` value + then break (== '-') value' + else error $ "Could not decode range: " ++ value + value' = drop 6 value + in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");" + name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");" setupAuth auth = - [ "$wc.Credentials = new-object System.Net.NetworkCredential(" + [ "$request.Credentials = new-object System.Net.NetworkCredential(" ++ escape uname ++ "," ++ escape passwd ++ ",\"\");" | (uname,passwd) <- maybeToList auth ] - uploadFileAction method uri fullPath = - [ "$fileBytes = [System.IO.File]::ReadAllBytes(" ++ escape fullPath ++ ");" - , "$bodyBytes = $wc.UploadData(" ++ escape (show uri) ++ "," - ++ show method ++ ", $fileBytes);" - , "Write-Host \"200\";" - , "Write-Host (-join [System.Text.Encoding]::UTF8.GetChars($bodyBytes));" + uploadFileAction method _uri fullPath = + [ "$request.Method = " ++ show method + , "$requestStream = $request.GetRequestStream()" + , "$fileStream = [System.IO.File]::OpenRead(" ++ escape fullPath ++ ")" + , "$bufSize=10000" + , "$chunk = New-Object byte[] $bufSize" + , "while( $bytesRead = $fileStream.Read($chunk,0,$bufsize) )" + , "{" + , " $requestStream.write($chunk, 0, $bytesRead)" + , " $requestStream.Flush()" + , "}" + , "" + , "$responseStream = $request.getresponse()" + , "$responseReader = new-object System.IO.StreamReader $responseStream.GetResponseStream()" + , "$code = $response.StatusCode -as [int]" + , "if ($code -eq 0) {" + , " $code = 200;" + , "}" + , "Write-Host $code" + , "Write-Host $responseReader.ReadToEnd()" ] + uploadFileCleanup = + [ "$fileStream.Close()" + , "$requestStream.Close()" + , "$responseStream.Close()" + ] + parseUploadResponse verbosity uri resp = case lines (trim resp) of (codeStr : message) | Just code <- readMaybe codeStr -> return (code, unlines message) _ -> statusParseFail verbosity uri resp - webclientScript setup action = unlines - [ "$wc = new-object system.net.webclient;" + webclientScript uri setup action cleanup = unlines + [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\"" + , "$uri = New-Object \"System.Uri\" " ++ uri + , "$request = [System.Net.HttpWebRequest]::Create($uri)" , unlines setup , "Try {" , unlines (map (" " ++) action) @@ -642,6 +712,8 @@ , " }" , "} Catch {" , " Write-Host $_.Exception.Message;" + , "} finally {" + , unlines (map (" " ++) cleanup) , "}" ] @@ -783,38 +855,3 @@ genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer return $ showHex i "" - ------------------------------------------------------------------------------- --- Compat utils - --- TODO: This is only here temporarily so we can release without also requiring --- the latest Cabal lib. The function is also included in Cabal now. - -getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation - -> IO (String, String, ExitCode) -getProgramInvocationOutputAndErrors verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokeCwd = mcwd, - progInvokeInput = minputStr, - progInvokeOutputEncoding = encoding - } = do - let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False - decode | utf8 = fromUTF8 . normaliseLineEndings - | otherwise = id - menv <- getEffectiveEnvironment envOverrides - (output, errors, exitCode) <- rawSystemStdInOut verbosity - path args - mcwd menv - input utf8 - return (decode output, decode errors, exitCode) - where - input = - case minputStr of - Nothing -> Nothing - Just inputStr -> Just $ - case encoding of - IOEncodingText -> (inputStr, False) - IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -20,6 +20,7 @@ module Distribution.Client.IndexUtils ( getIndexFileAge, getInstalledPackages, + indexBaseName, Configure.getInstalledPackagesMonitorFiles, getSourcePackages, getSourcePackagesMonitorFiles, @@ -32,6 +33,8 @@ parsePackageIndex, updateRepoIndexCache, updatePackageIndexCacheFile, + writeIndexTimestamp, + currentIndexTimestamp, readCacheStrict, -- only used by soon-to-be-obsolete sandbox code BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType @@ -63,7 +66,7 @@ import qualified Distribution.Simple.Configure as Configure ( getInstalledPackages, getInstalledPackagesMonitorFiles ) import Distribution.Version - ( Version, mkVersion, intersectVersionRanges, versionNumbers ) + ( Version, mkVersion, intersectVersionRanges ) import Distribution.Text ( display, simpleParse ) import Distribution.Simple.Utils @@ -71,19 +74,9 @@ import Distribution.Client.Setup ( RepoContext(..) ) -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec - ( parseGenericPackageDescriptionMaybe ) + ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe ) import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse -#else -import Distribution.ParseUtils - ( ParseResult(..) ) -import Distribution.PackageDescription.Parse - ( parseGenericPackageDescription ) -import Distribution.Simple.Utils - ( fromUTF8, ignoreBOM ) -import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse -#endif import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex @@ -96,7 +89,6 @@ import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS -import qualified Data.ByteString as BSW8 import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath @@ -197,7 +189,7 @@ -- This is a higher level wrapper used internally in cabal-install. getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb getSourcePackages verbosity repoCtxt = - getSourcePackagesAtIndexState verbosity repoCtxt IndexStateHead + getSourcePackagesAtIndexState verbosity repoCtxt Nothing -- | Variant of 'getSourcePackages' which allows getting the source -- packages at a particular 'IndexState'. @@ -208,7 +200,7 @@ -- TODO: Enhance to allow specifying per-repo 'IndexState's and also -- report back per-repo 'IndexStateInfo's (in order for @new-freeze@ -- to access it) -getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> IndexState +getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe IndexState -> IO SourcePackageDb getSourcePackagesAtIndexState verbosity repoCtxt _ | null (repoContextRepos repoCtxt) = do @@ -221,22 +213,36 @@ packageIndex = mempty, packagePreferences = mempty } -getSourcePackagesAtIndexState verbosity repoCtxt idxState = do - case idxState of - IndexStateHead -> info verbosity "Reading available packages..." - IndexStateTime time -> - info verbosity ("Reading available packages (for index-state as of " - ++ display time ++ ")...") +getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do + let describeState IndexStateHead = "most recent state" + describeState (IndexStateTime time) = "historical state as of " ++ display time pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do let rname = maybe "" remoteRepoName $ maybeRepoRemote r + info verbosity ("Reading available packages of " ++ rname ++ "...") + + idxState <- case mb_idxState of + Just idxState -> do + info verbosity $ "Using " ++ describeState idxState ++ + " as explicitly requested (via command line / project configuration)" + return idxState + Nothing -> do + mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r) + case mb_idxState' of + Nothing -> do + info verbosity "Using most recent state (could not read timestamp file)" + return IndexStateHead + Just idxState -> do + info verbosity $ "Using " ++ describeState idxState ++ + " specified from most recent cabal update" + return idxState + unless (idxState == IndexStateHead) $ case r of RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')") RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')") RepoSecure {} -> pure () - let idxState' = case r of RepoSecure {} -> idxState _ -> IndexStateHead @@ -250,10 +256,17 @@ return () IndexStateTime ts0 -> do when (isiMaxTime isi /= ts0) $ - warn verbosity ("Requested index-state " ++ display ts0 + if ts0 > isiMaxTime isi + then warn verbosity $ + "Requested index-state" ++ display ts0 + ++ " is newer than '" ++ rname ++ "'!" + ++ " Falling back to older state (" + ++ display (isiMaxTime isi) ++ ")." + else info verbosity $ + "Requested index-state " ++ display ts0 ++ " does not exist in '"++rname++"'!" ++ " Falling back to older state (" - ++ display (isiMaxTime isi) ++ ").") + ++ display (isiMaxTime isi) ++ ")." info verbosity ("index-state("++rname++") = " ++ display (isiMaxTime isi) ++ " (HEAD = " ++ display (isiHeadTime isi) ++ ")") @@ -270,12 +283,12 @@ packagePreferences = prefs' } -readCacheStrict :: Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency]) +readCacheStrict :: NFData pkg => Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency]) readCacheStrict verbosity index mkPkg = do updateRepoIndexCache verbosity index cache <- readIndexCache verbosity index withFile (indexFile index) ReadMode $ \indexHnd -> - packageListFromCache verbosity mkPkg indexHnd cache ReadPackageIndexStrict + evaluate . force =<< packageListFromCache verbosity mkPkg indexHnd cache -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. @@ -344,7 +357,9 @@ -- getSourcePackagesMonitorFiles :: [Repo] -> [FilePath] getSourcePackagesMonitorFiles repos = - [ indexBaseName repo <.> "cache" | repo <- repos ] + concat [ [ indexBaseName repo <.> "cache" + , indexBaseName repo <.> "timestamp" ] + | repo <- repos ] -- | It is not necessary to call this, as the cache will be updated when the -- index is read normally. However you can do the work earlier if you like. @@ -448,20 +463,11 @@ Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo) where pkgid = PackageIdentifier (mkPackageName pkgname) ver -#ifdef CABAL_PARSEC parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content) descr = case parsed of Just d -> d Nothing -> error $ "Couldn't read cabal file " ++ show fileName -#else - parsed = parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack - $ content - descr = case parsed of - ParseOk _ d -> d - _ -> error $ "Couldn't read cabal file " - ++ show fileName -#endif _ -> Nothing _ -> Nothing @@ -546,6 +552,10 @@ cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache" cacheFile (SandboxIndex index) = index `replaceExtension` "cache" +timestampFile :: Index -> FilePath +timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp" +timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp" + -- | Return 'True' if 'Index' uses 01-index format (aka secure repo) is01Index :: Index -> Bool is01Index (RepoIndex _ repo) = case repo of @@ -626,9 +636,6 @@ toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo toCache (Dep d) = CachePreference d 0 nullTimestamp -data ReadPackageIndexMode = ReadPackageIndexStrict - | ReadPackageIndexLazyIO - readPackageIndexCacheFile :: Package pkg => Verbosity -> (PackageEntry -> pkg) @@ -639,7 +646,7 @@ cache0 <- readIndexCache verbosity index indexHnd <- openFile (indexFile index) ReadMode let (cache,isi) = filterCache idxState cache0 - (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache ReadPackageIndexLazyIO + (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache pure (pkgs,deps,isi) @@ -648,10 +655,9 @@ -> (PackageEntry -> pkg) -> Handle -> Cache - -> ReadPackageIndexMode -> IO (PackageIndex pkg, [Dependency]) -packageIndexFromCache verbosity mkPkg hnd cache mode = do - (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache mode +packageIndexFromCache verbosity mkPkg hnd cache = do + (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache pkgIndex <- evaluate $ PackageIndex.fromList pkgs return (pkgIndex, prefs) @@ -668,9 +674,8 @@ -> (PackageEntry -> pkg) -> Handle -> Cache - -> ReadPackageIndexMode -> IO ([pkg], [Dependency]) -packageListFromCache verbosity mkPkg hnd Cache{..} mode = accum mempty [] mempty cacheEntries +packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries where accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs) @@ -683,9 +688,7 @@ pkgtxt <- getEntryContent blockno pkg <- readPackageDescription pkgid pkgtxt return (pkg, pkgtxt) - case mode of - ReadPackageIndexLazyIO -> pure () - ReadPackageIndexStrict -> evaluate pkg *> evaluate pkgtxt *> pure () + let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno) accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries @@ -713,17 +716,12 @@ -> return content _ -> interror "unexpected tar entry type" - interror :: String -> IO a - interror msg = die' verbosity $ "internal error when reading package index: " ++ msg - ++ "The package index or index cache is probably " - ++ "corrupt. Running cabal update might fix it." - - readPackageDescription pkgid content = do - case parseGenericPackageDescription' content of - ParseGPDOk gpd -> return gpd - ParseError (Just specVer) | specVer >= mkVersion [2,0] - -> return (dummyPackageDescription specVer) - ParseError _ -> interror "failed to parse .cabal file" + readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription + readPackageDescription pkgid content = + case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of + Right gpd -> return gpd + Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer) + Left _ -> interror "failed to parse .cabal file" where dummyPackageDescription :: Version -> GenericPackageDescription dummyPackageDescription specVer = GenericPackageDescription @@ -743,73 +741,13 @@ dummySynopsis = "" --- | Result of 'parseGenericPackageDescription'' -data ParseGPDResult = ParseGPDOk GenericPackageDescription - -- ^ parsing succeeded (may still have unsupported spec-version) - | ParseError !(Maybe Version) - -- ^ parsing failed, but we were able to recover - -- a new-style spec-version declaration + interror :: String -> IO a + interror msg = die' verbosity $ "internal error when reading package index: " ++ msg + ++ "The package index or index cache is probably " + ++ "corrupt. Running cabal update might fix it." --- | Variant of 'parseGenericPackageDescription' which is able to --- extract new-style spec-version in case of parser errors -parseGenericPackageDescription' :: ByteString -> ParseGPDResult -parseGenericPackageDescription' content = - case parseGPDMaybe of - Just gpd -> ParseGPDOk gpd - Nothing -> ParseError (scanSpecVersion content) - where - parseGPDMaybe = -#ifdef CABAL_PARSEC - parseGenericPackageDescriptionMaybe (BS.toStrict content) -#else - case parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of - ParseOk _ d -> Just d - _ -> Nothing -#endif --- | Quickly scan new-style spec-version --- --- A new-style spec-version declaration begins the .cabal file and --- follow the following case-insensitive grammar (expressed in --- RFC5234 ABNF): --- --- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS --- --- spec-version = NUM "." NUM [ "." NUM ] --- --- NUM = DIGIT0 / DIGITP 1*DIGIT0 --- DIGIT0 = %x30-39 --- DIGITP = %x31-39 --- WS = %20 --- --- TODO: move into lib:Cabal -scanSpecVersion :: ByteString -> Maybe Version -scanSpecVersion bs = do - fstline':_ <- pure (BS.Char8.lines bs) - -- parse - -- normalise: remove all whitespace, convert to lower-case - let fstline = BSW8.map toLowerW8 $ BSW8.filter (/= 0x20) $ BS.toStrict fstline' - ["cabal-version",vers] <- pure (BSS.split ':' fstline) - - -- parse - -- - -- This is currently more tolerant regarding leading 0 digits. - -- - ver <- simpleParse (BSS.unpack vers) - guard $ case versionNumbers ver of - [_,_] -> True - [_,_,_] -> True - _ -> False - - pure ver - where - -- | Translate ['A'..'Z'] to ['a'..'z'] - toLowerW8 :: Word8 -> Word8 - toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20 - | otherwise = w - - ------------------------------------------------------------------------ -- Index cache data structure -- @@ -848,6 +786,31 @@ writeIndexCache index cache | is01Index index = encodeFile (cacheFile index) cache | otherwise = writeFile (cacheFile index) (show00IndexCache cache) + +-- | Write the 'IndexState' to the filesystem +writeIndexTimestamp :: Index -> IndexState -> IO () +writeIndexTimestamp index st + = writeFile (timestampFile index) (display st) + +-- | Read out the "current" index timestamp, i.e., what +-- timestamp you would use to revert to this version +currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp +currentIndexTimestamp verbosity repoCtxt r = do + mb_is <- readIndexTimestamp (RepoIndex repoCtxt r) + case mb_is of + Just (IndexStateTime ts) -> return ts + _ -> do + (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead + return (isiHeadTime isi) + +-- | Read the 'IndexState' from the filesystem +readIndexTimestamp :: Index -> IO (Maybe IndexState) +readIndexTimestamp index + = fmap simpleParse (readFile (timestampFile index)) + `catchIO` \e -> + if isDoesNotExistError e + then return Nothing + else ioError e -- | Optimise sharing of equal values inside 'Cache' -- diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -60,7 +60,8 @@ import Language.Haskell.Extension ( Language(..) ) import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..), Category(..) ) + ( InitFlags(..), BuildType(..), PackageType(..), Category(..) + , displayPackageType ) import Distribution.Client.Init.Licenses ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) import Distribution.Client.Init.Heuristics @@ -75,6 +76,8 @@ ( runReadE, readP_to_E ) import Distribution.Simple.Setup ( Flag(..), flagToMaybe ) +import Distribution.Simple.Utils + ( dropWhileEndLE ) import Distribution.Simple.Configure ( getInstalledPackages ) import Distribution.Simple.Compiler @@ -207,8 +210,20 @@ ?>> fmap (fmap (either UnknownLicense id)) (maybePrompt flags (promptList "Please choose a license" listedLicenses (Just BSD3) display True)) - return $ flags { license = maybeToFlag lic } + + if isLicenseInvalid lic + then putStrLn promptInvalidOtherLicenseMsg >> getLicense flags + else return $ flags { license = maybeToFlag lic } + where + isLicenseInvalid (Just (UnknownLicense t)) = any (not . isAlphaNum) t + isLicenseInvalid _ = False + + promptInvalidOtherLicenseMsg = "\nThe license must be alphanumeric. " ++ + "If your license name has many words, " ++ + "the convention is to use camel case (e.g. PublicDomain). " ++ + "Please choose a different license." + listedLicenses = knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing , Apache Nothing, OtherLicense] @@ -298,16 +313,16 @@ -- | Ask whether the project builds a library or executable. getLibOrExec :: InitFlags -> IO InitFlags getLibOrExec flags = do - isLib <- return (flagToMaybe $ packageType flags) + pkgType <- return (flagToMaybe $ packageType flags) ?>> maybePrompt flags (either (const Library) id `fmap` promptList "What does the package build" - [Library, Executable] - Nothing display False) + [Library, Executable, LibraryAndExecutable] + Nothing displayPackageType False) ?>> return (Just Library) - mainFile <- if isLib /= Just Executable then return Nothing else + mainFile <- if pkgType == Just Library then return Nothing else getMainFile flags - return $ flags { packageType = maybeToFlag isLib + return $ flags { packageType = maybeToFlag pkgType , mainIs = maybeToFlag mainFile } @@ -338,8 +353,17 @@ (Just Haskell2010) display True) ?>> return (Just Haskell2010) - return $ flags { language = maybeToFlag lang } + if invalidLanguage lang + then putStrLn invalidOtherLanguageMsg >> getLanguage flags + else return $ flags { language = maybeToFlag lang } + where + invalidLanguage (Just (UnknownLanguage t)) = any (not . isAlphaNum) t + invalidLanguage _ = False + + invalidOtherLanguageMsg = "\nThe language must be alphanumeric. " ++ + "Please enter a different language." + -- | Ask whether to generate explanatory comments. getGenComments :: InitFlags -> IO InitFlags getGenComments flags = do @@ -671,14 +695,14 @@ ] writeChangeLog :: InitFlags -> IO () -writeChangeLog flags = when (any (== defaultChangeLog) $ maybe [] id (extraSrc flags)) $ do +writeChangeLog flags = when ((defaultChangeLog `elem`) $ fromMaybe [] (extraSrc flags)) $ do message flags ("Generating "++ defaultChangeLog ++"...") writeFileSafe flags defaultChangeLog changeLog where changeLog = unlines [ "# Revision history for " ++ pname , "" - , "## " ++ pver ++ " -- YYYY-mm-dd" + , "## " ++ pver ++ " -- YYYY-mm-dd" , "" , "* First version. Released on an unsuspecting world." ] @@ -713,17 +737,16 @@ -- | Create Main.hs, but only if we are init'ing an executable and -- the mainIs flag has been provided. createMainHs :: InitFlags -> IO () -createMainHs flags@InitFlags{ sourceDirs = Just (srcPath:_) - , packageType = Flag Executable - , mainIs = Flag mainFile } = - writeMainHs flags (srcPath mainFile) -createMainHs flags@InitFlags{ sourceDirs = _ - , packageType = Flag Executable - , mainIs = Flag mainFile } = - writeMainHs flags mainFile -createMainHs _ = return () +createMainHs flags = + if hasMainHs flags then + case sourceDirs flags of + Just (srcPath:_) -> writeMainHs flags (srcPath mainFile) + _ -> writeMainHs flags mainFile + else return () + where + Flag mainFile = mainIs flags --- | Write a main file if it doesn't already exist. +--- | Write a main file if it doesn't already exist. writeMainHs :: InitFlags -> FilePath -> IO () writeMainHs flags mainPath = do dir <- maybe getCurrentDirectory return (flagToMaybe $ packageDir flags) @@ -733,6 +756,13 @@ message flags $ "Generating " ++ mainPath ++ "..." writeFileSafe flags mainFullPath mainHs +-- | Check that a main file exists. +hasMainHs :: InitFlags -> Bool +hasMainHs flags = case mainIs flags of + Flag _ -> (packageType flags == Flag Executable + || packageType flags == Flag LibraryAndExecutable) + _ -> False + -- | Default Main.hs file. Used when no Main.hs exists. mainHs :: String mainHs = unlines @@ -771,7 +801,7 @@ -- structure onto a low-level AST structure and use the existing -- pretty-printing code to generate the file. generateCabalFile :: String -> InitFlags -> String -generateCabalFile fileName c = +generateCabalFile fileName c = trimTrailingWS $ (++ "\n") . renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $ (if minimal c /= Flag True @@ -849,30 +879,18 @@ False , case packageType c of - Flag Executable -> - text "\nexecutable" <+> - text (maybe "" display . flagToMaybe $ packageName c) $$ - nest 2 (vcat - [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True - - , generateBuildInfo Executable c - ]) - Flag Library -> text "\nlibrary" $$ nest 2 (vcat - [ fieldS "exposed-modules" (listField (exposedModules c)) - (Just "Modules exported by the library.") - True - - , generateBuildInfo Library c - ]) + Flag Executable -> executableStanza + Flag Library -> libraryStanza + Flag LibraryAndExecutable -> libraryStanza $+$ executableStanza _ -> empty ] where - generateBuildInfo :: PackageType -> InitFlags -> Doc - generateBuildInfo pkgtype c' = vcat + generateBuildInfo :: BuildType -> InitFlags -> Doc + generateBuildInfo buildType c' = vcat [ fieldS "other-modules" (listField (otherModules c')) - (Just $ case pkgtype of - Library -> "Modules included in this library but not exported." - Executable -> "Modules included in this executable, other than Main.") + (Just $ case buildType of + LibBuild -> "Modules included in this library but not exported." + ExecBuild -> "Modules included in this executable, other than Main.") True , fieldS "other-extensions" (listField (otherExts c')) @@ -942,6 +960,28 @@ breakLine cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs' breakLine' [] = [] breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs' + + trimTrailingWS :: String -> String + trimTrailingWS = unlines . map (dropWhileEndLE isSpace) . lines + + executableStanza :: Doc + executableStanza = text "\nexecutable" <+> + text (maybe "" display . flagToMaybe $ packageName c) $$ + nest 2 (vcat + [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True + + , generateBuildInfo ExecBuild c + ]) + + libraryStanza :: Doc + libraryStanza = text "\nlibrary" $$ nest 2 (vcat + [ fieldS "exposed-modules" (listField (exposedModules c)) + (Just "Modules exported by the library.") + True + + , generateBuildInfo LibBuild c + ]) + -- | Generate warnings for missing fields etc. generateWarnings :: InitFlags -> IO () diff --git a/Distribution/Client/Init/Types.hs b/Distribution/Client/Init/Types.hs --- a/Distribution/Client/Init/Types.hs +++ b/Distribution/Client/Init/Types.hs @@ -78,12 +78,14 @@ -- ones, which is why we want Maybe [foo] for collecting foo values, -- not Flag [foo]. -data PackageType = Library | Executable +data BuildType = LibBuild | ExecBuild + +data PackageType = Library | Executable | LibraryAndExecutable deriving (Show, Read, Eq) -instance Text PackageType where - disp = Disp.text . show - parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] -- TODO: eradicateNoParse +displayPackageType :: PackageType -> String +displayPackageType LibraryAndExecutable = "Library and Executable" +displayPackageType pkgtype = show pkgtype instance Monoid InitFlags where mempty = gmempty diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -32,8 +32,6 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Data.List - ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as S import Control.Exception as Exception @@ -72,7 +70,7 @@ import Distribution.Solver.Types.PackageFixedDeps import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackagesAtIndexState, IndexState(..), getInstalledPackages ) + ( getSourcePackagesAtIndexState, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.InstallPlan (InstallPlan) @@ -125,7 +123,6 @@ import Distribution.Simple.Setup ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags - , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) @@ -150,7 +147,8 @@ import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription ( PackageDescription, GenericPackageDescription(..), Flag(..) - , FlagAssignment, showFlagValue ) + , FlagAssignment, mkFlagAssignment, unFlagAssignment + , showFlagValue, diffFlagAssignment, nullFlagAssignment ) import Distribution.PackageDescription.Configuration ( finalizePD ) import Distribution.ParseUtils @@ -277,8 +275,7 @@ (packageDBs, repoCtxt, comp, _, progdb,_,_, globalFlags, _, configExFlags, installFlags, _) mUserTargets = do - let idxState = fromFlagOrDefault IndexStateHead $ - installIndexState installFlags + let idxState = flagToMaybe (installIndexState installFlags) installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState @@ -340,7 +337,7 @@ unless (dryRun || nothingToInstall) $ do buildOutcomes <- performInstallations verbosity - args installedPkgIndex installPlan + args installedPkgIndex installPlan postInstallActions verbosity args userTargets installPlan buildOutcomes where installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 @@ -421,7 +418,7 @@ (PackagePropertyFlags flags) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget | let flags = configConfigurationsFlags configFlags - , not (null flags) + , not (nullFlagAssignment flags) , pkgSpecifier <- pkgSpecifiers ] . addConstraints @@ -459,11 +456,12 @@ allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags) upgradeDeps = fromFlag (installUpgradeDeps installFlags) onlyDeps = fromFlag (installOnlyDeps installFlags) - allowOlder = fromMaybe (AllowOlder RelaxDepsNone) - (configAllowOlder configFlags) - allowNewer = fromMaybe (AllowNewer RelaxDepsNone) - (configAllowNewer configFlags) + allowOlder = fromMaybe (AllowOlder mempty) + (configAllowOlder configExFlags) + allowNewer = fromMaybe (AllowNewer mempty) + (configAllowNewer configExFlags) + -- | Remove the provided targets from the install plan. pruneInstallPlan :: Package targetpkg => [PackageSpecifier targetpkg] @@ -640,8 +638,7 @@ nub . sort . map mungedId - . catMaybes - . map (PackageIndex.lookupUnitId installedPkgIndex) + . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex) changed (InBoth pkgid pkgid') = pkgid /= pkgid' changed _ = True @@ -697,7 +694,7 @@ x -> Just $ packageVersion $ last x toFlagAssignment :: [Flag] -> FlagAssignment - toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) + toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment nonDefaultFlags cpkg = @@ -705,13 +702,13 @@ toFlagAssignment (genPackageFlags (SourcePackage.packageDescription $ confPkgSource cpkg)) - in confPkgFlags cpkg \\ defaultAssignment + in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment showStanzas :: [OptionalStanza] -> String showStanzas = concatMap ((" *" ++) . showStanza) showFlagAssignment :: FlagAssignment -> String - showFlagAssignment = concatMap ((' ' :) . showFlagValue) + showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment change (OnlyInLeft pkgid) = display pkgid ++ " removed" change (InBoth pkgid pkgid') = display pkgid ++ " -> " @@ -756,7 +753,7 @@ (compilerId comp) pkgids (configConfigurationsFlags configFlags) - when (not (null buildReports)) $ + unless (null buildReports) $ info verbosity $ "Solver failure will be reported for " ++ intercalate "," (map display pkgids) @@ -824,10 +821,13 @@ ,globalFlags, configFlags, _, installFlags, _) targets installPlan buildOutcomes = do + updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo + comp platform installPlan buildOutcomes + unless oneShot $ World.insert verbosity worldFile --FIXME: does not handle flags - [ World.WorldPkgInfo dep [] + [ World.WorldPkgInfo dep mempty | UserTargetNamed dep <- targets ] let buildReports = BuildReports.fromInstallPlan platform (compilerId comp) @@ -849,9 +849,6 @@ printBuildFailures verbosity buildOutcomes - updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo - comp platform installPlan buildOutcomes - where reportingLevel = fromFlag (installBuildReports installFlags) logsDir = fromFlag (globalLogsDir globalFlags) @@ -1120,7 +1117,7 @@ platform progdb distPref - (chooseCabalVersion configFlags (libVersion miscOptions)) + (chooseCabalVersion configExFlags (libVersion miscOptions)) (Just lock) parallelInstall index @@ -1319,7 +1316,7 @@ ++ " to " ++ tmpDirPath ++ "..." extractTarGzFile tmpDirPath relUnpackedPath tarballPath exists <- doesFileExist descFilePath - when (not exists) $ + unless exists $ die' verbosity $ "Package .cabal file not found: " ++ show descFilePath maybeRenameDistDir absUnpackedPath installPkg (Just absUnpackedPath) diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -97,7 +97,7 @@ ( foldl', intercalate ) import qualified Data.Foldable as Foldable (all) import Data.Maybe - ( fromMaybe, catMaybes ) + ( fromMaybe, mapMaybe ) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Compat.Binary (Binary(..)) @@ -905,10 +905,9 @@ problems graph = [ PackageMissingDeps pkg - (catMaybes - (map + (mapMaybe (fmap nodeKey . flip Graph.lookup graph) - missingDeps)) + missingDeps) | (pkg, missingDeps) <- Graph.broken graph ] ++ [ PackageCycle cycleGroup diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -26,6 +26,7 @@ ( Flag(..), unFlagName ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) +import Distribution.Pretty (pretty) import Distribution.Simple.Compiler ( Compiler, PackageDBStack ) @@ -42,15 +43,16 @@ import Distribution.Text ( Text(disp), display ) +import qualified Distribution.SPDX as SPDX + import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.SourcePackage import Distribution.Client.Types - ( SourcePackageDb(..) - , UnresolvedSourcePackage ) + ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Client.Targets - ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) + ( UserTarget, resolveUserTargets ) import Distribution.Client.Setup ( GlobalFlags(..), ListFlags(..), InfoFlags(..) , RepoContext(..) ) @@ -281,7 +283,7 @@ synopsis :: String, description :: String, category :: String, - license :: License, + license :: Either SPDX.License License, author :: String, maintainer :: String, dependencies :: [ExtDependency], @@ -317,7 +319,7 @@ versions -> dispTopVersions 4 (preferredVersions pkginfo) versions , maybeShow (homepage pkginfo) "Homepage:" text - , text "License: " <+> text (display (license pkginfo)) + , text "License: " <+> either pretty pretty (license pkginfo) ]) $+$ text "" where @@ -328,9 +330,9 @@ showPackageDetailedInfo pkginfo = renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ char '*' <+> disp (pkgName pkginfo) - <> maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo) + Disp.<> maybe empty (\v -> char '-' Disp.<> disp v) (selectedVersion pkginfo) <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ') - <> parens pkgkind + Disp.<> parens pkgkind $+$ (nest 4 $ vcat [ entry "Synopsis" synopsis hideIfNull reflowParagraphs @@ -345,7 +347,7 @@ , entry "Bug reports" bugReports orNotSpecified text , entry "Description" description hideIfNull reflowParagraphs , entry "Category" category hideIfNull text - , entry "License" license alwaysShow disp + , entry "License" license alwaysShow (either pretty pretty) , entry "Author" author hideIfNull reflowLines , entry "Maintainer" maintainer hideIfNull reflowLines , entry "Source repo" sourceRepo orNotSpecified text @@ -364,7 +366,7 @@ Just Nothing -> empty Just (Just other) -> label <+> text other where - label = text fname <> char ':' <> padding + label = text fname Disp.<> char ':' Disp.<> padding padding = text (replicate (13 - length fname ) ' ') normal = Nothing @@ -436,7 +438,7 @@ sourceVersions = map packageVersion sourcePkgs, preferredVersions = versionPref, - license = combine Source.license source + license = combine Source.licenseRaw source Installed.license installed, maintainer = combine Source.maintainer source Installed.maintainer installed, @@ -458,10 +460,8 @@ Installed.category installed, flags = maybe [] Source.genPackageFlags sourceGeneric, hasLib = isJust installed - || fromMaybe False - (fmap (isJust . Source.condLibrary) sourceGeneric), - hasExe = fromMaybe False - (fmap (not . null . Source.condExecutables) sourceGeneric), + || maybe False (isJust . Source.condLibrary) sourceGeneric, + hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric, executables = map fst (maybe [] Source.condExecutables sourceGeneric), modules = combine (map Installed.exposedName . Installed.exposedModules) installed diff --git a/Distribution/Client/Nix.hs b/Distribution/Client/Nix.hs --- a/Distribution/Client/Nix.hs +++ b/Distribution/Client/Nix.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} @@ -10,12 +9,9 @@ , nixShellIfSandboxed ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif +import Distribution.Client.Compat.Prelude import Control.Exception (bracket, catch) -import Control.Monad (filterM, when, unless) import System.Directory ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist , doesFileExist, removeDirectoryRecursive, removeFile ) @@ -28,7 +24,6 @@ import Distribution.Compat.Environment ( lookupEnv, setEnv, unsetEnv ) -import Distribution.Compat.Semigroup import Distribution.Verbosity @@ -179,7 +174,7 @@ inNixShell :: IO Bool -inNixShell = maybe False (const True) <$> lookupEnv "CABAL_IN_NIX_SHELL" +inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL" removeGCRoots :: Verbosity -> FilePath -> IO () diff --git a/Distribution/Client/Outdated.hs b/Distribution/Client/Outdated.hs --- a/Distribution/Client/Outdated.hs +++ b/Distribution/Client/Outdated.hs @@ -27,7 +27,8 @@ import Distribution.Solver.Types.PackageIndex import Distribution.Client.Sandbox.PackageEnvironment -import Distribution.Package (PackageName, packageVersion) +import Distribution.Package (PackageName + ,packageVersion) import Distribution.PackageDescription (buildDepends) import Distribution.PackageDescription.Configuration (finalizePD) import Distribution.Simple.Compiler (Compiler, compilerInfo) @@ -36,20 +37,16 @@ (die', notice, debug, tryFindPackageDesc) import Distribution.System (Platform) import Distribution.Text (display) -import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..)) +import Distribution.Types.ComponentRequestedSpec + (ComponentRequestedSpec(..)) import Distribution.Types.Dependency (Dependency(..), depPkgName, simplifyDependency) import Distribution.Verbosity (Verbosity, silent) import Distribution.Version (Version, LowerBound(..), UpperBound(..) ,asVersionIntervals, majorBoundVersion) -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec (readGenericPackageDescription) -#else -import Distribution.PackageDescription.Parse - (readGenericPackageDescription) -#endif import qualified Data.Set as S import System.Directory (getCurrentDirectory) @@ -64,7 +61,8 @@ let freezeFile = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags) newFreezeFile = fromFlagOrDefault False (outdatedNewFreezeFile outdatedFlags) - simpleOutput = fromFlagOrDefault False (outdatedSimpleOutput outdatedFlags) + simpleOutput = fromFlagOrDefault False + (outdatedSimpleOutput outdatedFlags) quiet = fromFlagOrDefault False (outdatedQuiet outdatedFlags) exitCode = fromFlagOrDefault quiet (outdatedExitCode outdatedFlags) ignorePred = let ignoreSet = S.fromList (outdatedIgnore outdatedFlags) @@ -119,7 +117,8 @@ depsFromFreezeFile verbosity = do cwd <- getCurrentDirectory userConfig <- loadUserConfig verbosity cwd Nothing - let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ userConfig + let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $ + userConfig deps = userConstraintsToDependencies ucnstrs debug verbosity "Reading the list of dependencies from the freeze file" return deps @@ -128,8 +127,10 @@ depsFromNewFreezeFile :: Verbosity -> IO [Dependency] depsFromNewFreezeFile verbosity = do projectRoot <- either throwIO return =<< - findProjectRoot Nothing {- TODO: Support '--project-file': -} Nothing - let distDirLayout = defaultDistDirLayout projectRoot {- TODO: Support dist dir override -} Nothing + findProjectRoot Nothing + {- TODO: Support '--project-file': -} Nothing + let distDirLayout = defaultDistDirLayout projectRoot + {- TODO: Support dist dir override -} Nothing projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ readProjectLocalFreezeConfig verbosity distDirLayout let ucnstrs = map fst . projectConfigConstraints . projectConfigShared @@ -146,7 +147,7 @@ path <- tryFindPackageDesc cwd gpd <- readGenericPackageDescription verbosity path let cinfo = compilerInfo comp - epd = finalizePD [] (ComponentRequestedSpec True True) + epd = finalizePD mempty (ComponentRequestedSpec True True) (const True) platform cinfo [] gpd case epd of Left _ -> die' verbosity "finalizePD failed" @@ -183,9 +184,10 @@ isOutdated' :: [Version] -> [Version] -> Maybe Version isOutdated' [] _ = Nothing isOutdated' _ [] = Nothing - isOutdated' this latest = let this' = maximum this - latest' = maximum latest - in if this' < latest' then Just latest' else Nothing + isOutdated' this latest = + let this' = maximum this + latest' = maximum latest + in if this' < latest' then Just latest' else Nothing lookupLatest :: Dependency -> [Version] lookupLatest dep diff --git a/Distribution/Client/PackageHash.hs b/Distribution/Client/PackageHash.hs --- a/Distribution/Client/PackageHash.hs +++ b/Distribution/Client/PackageHash.hs @@ -29,13 +29,16 @@ hashFromTUF, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Package ( PackageId, PackageIdentifier(..), mkComponentId , PkgconfigName ) import Distribution.System - ( Platform, OS(Windows), buildOS ) + ( Platform, OS(Windows, OSX), buildOS ) import Distribution.PackageDescription - ( FlagAssignment, showFlagValue ) + ( FlagAssignment, unFlagAssignment, showFlagValue ) import Distribution.Simple.Compiler ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..) , ProfDetailLevel(..), showProfDetailLevel ) @@ -58,12 +61,7 @@ import qualified Data.Set as Set import Data.Set (Set) -import Data.Typeable -import Data.Maybe (catMaybes) -import Data.List (sortBy, intercalate) -import Data.Map (Map) import Data.Function (on) -import Distribution.Compat.Binary (Binary(..)) import Control.Exception (evaluate) import System.IO (withBinaryFile, IOMode(..)) @@ -82,6 +80,7 @@ hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageId | buildOS == Windows = hashedInstalledPackageIdShort + | buildOS == OSX = hashedInstalledPackageIdVeryShort | otherwise = hashedInstalledPackageIdLong -- | Calculate a 'InstalledPackageId' for a package using our nix-style @@ -135,6 +134,41 @@ truncateStr n s | length s <= n = s | otherwise = take (n-1) s ++ "_" +-- | On macOS we shorten the name very aggressively. The mach-o linker on +-- macOS has a limited load command size, to which the name of the lirbary +-- as well as its relative path (\@rpath) entry count. To circumvent this, +-- on macOS the libraries are not stored as +-- @store//libHS.dylib@ +-- where libraryname contains the librarys name, version and abi hash, but in +-- @store/lib/libHS.dylib@ +-- where the very short library name drops all vowels from the package name, +-- and truncates the hash to 4 bytes. +-- +-- We therefore only need one \@rpath entry to @store/lib@ instead of one +-- \@rpath entry for each library. And the reduced library name saves some +-- additional space. +-- +-- This however has two major drawbacks: +-- 1) Packages can easier collide due to the shortened hash. +-- 2) The lirbaries are *not* prefix relocateable anymore as they all end up +-- in the same @store/lib@ folder. +-- +-- The ultimate solution would have to include generating proxy dynamic +-- libraries on macOS, such that the proxy libraries and the linked libraries +-- stay under the load command limit, and the recursive linker is still able +-- to link all of them. +hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId +hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = + mkComponentId $ + intercalate "-" + [ filter (not . flip elem "aeiou") (display name) + , display version + , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs)) + ] + where + PackageIdentifier name version = pkgHashPkgId + truncateHash (HashValue h) = HashValue (BS.take 4 h) + -- | All the information that contribues to a package's hash, and thus its -- 'InstalledPackageId'. -- @@ -168,6 +202,7 @@ pkgHashCoverage :: Bool, pkgHashOptimization :: OptimisationLevel, pkgHashSplitObjs :: Bool, + pkgHashSplitSections :: Bool, pkgHashStripLibs :: Bool, pkgHashStripExes :: Bool, pkgHashDebugInfo :: DebugInfoLevel, @@ -233,7 +268,7 @@ -- and then all the config , entry "compilerid" display pkgHashCompilerId , entry "platform" display pkgHashPlatform - , opt "flags" [] showFlagAssignment pkgHashFlagAssignment + , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment , opt "configure-script" [] unwords pkgHashConfigureScriptArgs , opt "vanilla-lib" True display pkgHashVanillaLib , opt "shared-lib" False display pkgHashSharedLib @@ -246,6 +281,7 @@ , opt "hpc" False display pkgHashCoverage , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization , opt "split-objs" False display pkgHashSplitObjs + , opt "split-sections" False display pkgHashSplitSections , opt "stripped-lib" False display pkgHashStripLibs , opt "stripped-exe" True display pkgHashStripExes , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo @@ -262,7 +298,7 @@ | value == def = Nothing | otherwise = entry key format value - showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) + showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment ----------------------------------------------- -- The specific choice of hash implementation diff --git a/Distribution/Client/ParseUtils.hs b/Distribution/Client/ParseUtils.hs --- a/Distribution/Client/ParseUtils.hs +++ b/Distribution/Client/ParseUtils.hs @@ -46,10 +46,10 @@ ( OptionField, viewAsFieldDescr ) import Control.Monad ( foldM ) -import Text.PrettyPrint ( (<>), (<+>), ($+$) ) +import Text.PrettyPrint ( (<+>), ($+$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp - ( Doc, text, colon, vcat, empty, isEmpty, nest ) + ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) ------------------------- @@ -162,8 +162,8 @@ ppField name mdef cur | Disp.isEmpty cur = maybe Disp.empty (\def -> Disp.text "--" <+> Disp.text name - <> Disp.colon <+> def) mdef - | otherwise = Disp.text name <> Disp.colon <+> cur + Disp.<> Disp.colon <+> def) mdef + | otherwise = Disp.text name Disp.<> Disp.colon <+> cur -- | Pretty print a section. -- diff --git a/Distribution/Client/ProjectBuilding.hs b/Distribution/Client/ProjectBuilding.hs --- a/Distribution/Client/ProjectBuilding.hs +++ b/Distribution/Client/ProjectBuilding.hs @@ -35,6 +35,10 @@ BuildFailureReason(..), ) where +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + import Distribution.Client.PackageHash (renderPackageHashInputs) import Distribution.Client.RebuildMonad import Distribution.Client.ProjectConfig @@ -65,6 +69,7 @@ import qualified Distribution.PackageDescription as PD import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Simple.BuildPaths (haddockDirName) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Types.BuildType import Distribution.Simple.Program @@ -87,6 +92,7 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.ByteString.Lazy as LBS +import Data.List (isPrefixOf) import Control.Monad import Control.Exception @@ -96,6 +102,12 @@ import System.IO import System.Directory +#if !MIN_VERSION_directory(1,2,5) +listDirectory :: FilePath -> IO [FilePath] +listDirectory path = + (filter f) <$> (getDirectoryContents path) + where f filename = filename /= "." && filename /= ".." +#endif ------------------------------------------------------------------------------ -- * Overall building strategy. @@ -356,6 +368,7 @@ elab { elabBuildTargets = [], elabTestTargets = [], + elabBenchTargets = [], elabReplTarget = Nothing, elabBuildHaddocks = False } @@ -676,7 +689,7 @@ verbosity distDirLayout storeDirLayout buildSettings registerLock cacheLock sharedPackageConfig - rpkg + plan rpkg srcdir builddir' where builddir' = makeRelative srcdir builddir @@ -692,8 +705,9 @@ buildStatus srcdir builddir ---TODO: [nice to have] do we need to use a with-style for the temp files for downloading http --- packages, or are we going to cache them persistently? +-- TODO: [nice to have] do we need to use a with-style for the temp +-- files for downloading http packages, or are we going to cache them +-- persistently? -- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the -- packages we have to download and fork off an async action to download them. @@ -824,7 +838,7 @@ -- Sanity check -- exists <- doesFileExist cabalFile - when (not exists) $ + unless exists $ die' verbosity $ "Package .cabal file not found in the tarball: " ++ cabalFile -- Overwrite the .cabal with the one from the index, when appropriate @@ -870,6 +884,7 @@ -> StoreDirLayout -> BuildTimeSettings -> Lock -> Lock -> ElaboratedSharedConfig + -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> FilePath -> FilePath -> IO BuildResult @@ -888,7 +903,7 @@ pkgConfigCompiler = compiler, pkgConfigCompilerProgs = progdb } - rpkg@(ReadyPackage pkg) + plan rpkg@(ReadyPackage pkg) srcdir builddir = do createDirectoryIfMissingVerbose verbosity True builddir @@ -922,6 +937,13 @@ annotateFailure mlogFile BuildFailed $ setup buildCommand buildFlags + -- Haddock phase + whenHaddock $ do + when isParallelBuild $ + notice verbosity $ "Generating " ++ dispname ++ " documentation..." + annotateFailureNoLog HaddocksFailed $ + setup haddockCommand haddockFlags + -- Install phase annotateFailure mlogFile InstallFailed $ do @@ -935,9 +957,25 @@ LBS.writeFile (entryDir "cabal-hash.txt") (renderPackageHashInputs (packageHashInputs pkgshared pkg)) + + -- Ensure that there are no files in `tmpDir`, that are not in `entryDir` + -- While this breaks the prefix-relocatable property of the lirbaries + -- it is necessary on macOS to stay under the load command limit of the + -- macOS mach-o linker. See also @PackageHash.hashedInstalledPackageIdVeryShort@. + otherFiles <- filter (not . isPrefixOf entryDir) <$> listFilesRecursive tmpDir -- here's where we could keep track of the installed files ourselves -- if we wanted to by making a manifest of the files in the tmp dir - return entryDir + return (entryDir, otherFiles) + where + listFilesRecursive :: FilePath -> IO [FilePath] + listFilesRecursive path = do + files <- fmap (path ) <$> (listDirectory path) + allFiles <- forM files $ \file -> do + isDir <- doesDirectoryExist file + if isDir + then listFilesRecursive file + else return [file] + return (concat allFiles) registerPkg | not (elabRequiresRegistration pkg) = @@ -992,6 +1030,10 @@ isParallelBuild = buildSettingNumJobs >= 2 + whenHaddock action + | elabBuildHaddocks pkg = action + | otherwise = return () + configureCommand = Cabal.configureCommand defaultProgramDb configureFlags v = flip filterConfigureFlags v $ setupHsConfigureFlags rpkg pkgshared @@ -1001,6 +1043,10 @@ buildCommand = Cabal.buildCommand defaultProgramDb buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir + haddockCommand = Cabal.haddockCommand + haddockFlags _ = setupHsHaddockFlags pkg pkgshared + verbosity builddir + generateInstalledPackageInfo :: IO InstalledPackageInfo generateInstalledPackageInfo = withTempInstalledPackageInfoFile @@ -1014,7 +1060,7 @@ copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity builddir destdir - scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir + scriptOptions = setupHsScriptOptions rpkg plan pkgshared srcdir builddir isParallelBuild cacheLock setup :: CommandUI flags -> (Version -> flags) -> IO () @@ -1025,7 +1071,9 @@ withLogging $ \mLogFileHandle -> setupWrapper verbosity - scriptOptions { useLoggingHandle = mLogFileHandle } + scriptOptions + { useLoggingHandle = mLogFileHandle + , useExtraEnvOverrides = dataDirsEnvironmentForPlan plan } (Just (elabPkgDescription pkg)) cmd flags args @@ -1061,7 +1109,8 @@ buildInplaceUnpackedPackage verbosity distDirLayout@DistDirLayout { distTempDirectory, - distPackageCacheDirectory + distPackageCacheDirectory, + distDirectory } BuildTimeSettings{buildSettingNumJobs} registerLock cacheLock @@ -1108,7 +1157,7 @@ ifNullThen m m' = do xs <- m if null xs then m' else return xs monitors <- case PD.buildType (elabPkgDescription pkg) of - Just Simple -> listSimple + Simple -> listSimple -- If a Custom setup was used, AND the Cabal is recent -- enough to have sdist --list-sources, use that to -- determine the files that we need to track. This can @@ -1158,6 +1207,10 @@ annotateFailureNoLog TestsFailed $ setup testCommand testFlags testArgs + whenBench $ + annotateFailureNoLog BenchFailed $ + setup benchCommand benchFlags benchArgs + -- Repl phase -- whenRepl $ @@ -1166,8 +1219,15 @@ -- Haddock phase whenHaddock $ - annotateFailureNoLog HaddocksFailed $ - setup haddockCommand haddockFlags [] + annotateFailureNoLog HaddocksFailed $ do + setup haddockCommand haddockFlags [] + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = distBuildDirectory distDirLayout dparams "doc" "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest return BuildResult { buildResultDocs = docsResult, @@ -1189,14 +1249,19 @@ whenRebuild action | null (elabBuildTargets pkg) - -- NB: we have to build the test suite! - , null (elabTestTargets pkg) = return () + -- NB: we have to build the test/bench suite! + , null (elabTestTargets pkg) + , null (elabBenchTargets pkg) = return () | otherwise = action whenTest action | null (elabTestTargets pkg) = return () | otherwise = action + whenBench action + | null (elabBenchTargets pkg) = return () + | otherwise = action + whenRepl action | isNothing (elabReplTarget pkg) = return () | otherwise = action @@ -1229,6 +1294,11 @@ verbosity builddir testArgs = setupHsTestArgs pkg + benchCommand = Cabal.benchmarkCommand + benchFlags _ = setupHsBenchFlags pkg pkgshared + verbosity builddir + benchArgs = setupHsBenchArgs pkg + replCommand = Cabal.replCommand defaultProgramDb replFlags _ = setupHsReplFlags pkg pkgshared verbosity builddir @@ -1238,7 +1308,7 @@ haddockFlags _ = setupHsHaddockFlags pkg pkgshared verbosity builddir - scriptOptions = setupHsScriptOptions rpkg pkgshared + scriptOptions = setupHsScriptOptions rpkg plan pkgshared srcdir builddir isParallelBuild cacheLock diff --git a/Distribution/Client/ProjectBuilding/Types.hs b/Distribution/Client/ProjectBuilding/Types.hs --- a/Distribution/Client/ProjectBuilding/Types.hs +++ b/Distribution/Client/ProjectBuilding/Types.hs @@ -201,6 +201,7 @@ | ReplFailed SomeException | HaddocksFailed SomeException | TestsFailed SomeException + | BenchFailed SomeException | InstallFailed SomeException deriving Show diff --git a/Distribution/Client/ProjectConfig.hs b/Distribution/Client/ProjectConfig.hs --- a/Distribution/Client/ProjectConfig.hs +++ b/Distribution/Client/ProjectConfig.hs @@ -20,6 +20,7 @@ -- * Project config files readProjectConfig, + readGlobalConfig, readProjectLocalFreezeConfig, writeProjectLocalExtraConfig, writeProjectLocalFreezeConfig, @@ -65,12 +66,12 @@ import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Config - ( loadConfig, defaultConfigFile ) -import Distribution.Client.IndexUtils.Timestamp - ( IndexState(..) ) + ( loadConfig, getConfigFilePath ) import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) import Distribution.Package ( PackageName, PackageId, packageId, UnitId ) @@ -79,20 +80,15 @@ ( Platform ) import Distribution.PackageDescription ( SourceRepo(..) ) -#if CABAL_PARSEC import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) -#else -import Distribution.PackageDescription.Parse - ( readGenericPackageDescription ) -#endif import Distribution.Simple.Compiler ( Compiler, compilerInfo ) import Distribution.Simple.Program ( ConfiguredProgram(..) ) import Distribution.Simple.Setup ( Flag(Flag), toFlag, flagToMaybe, flagToList - , fromFlag, fromFlagOrDefault, AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) + , fromFlag, fromFlagOrDefault ) import Distribution.Client.Setup ( defaultSolver, defaultMaxBackjumps ) import Distribution.Simple.InstallDirs @@ -113,7 +109,6 @@ import Control.Monad import Control.Monad.Trans (liftIO) import Control.Exception -import Data.Maybe import Data.Either import qualified Data.Map as Map import Data.Set (Set) @@ -157,6 +152,7 @@ buildSettingCacheDir buildSettingHttpTransport (Just buildSettingIgnoreExpiry) + buildSettingProgPathExtra -- | Use a 'RepoContext', but only for the solver. The solver does not use the @@ -179,6 +175,7 @@ projectConfigCacheDir) (flagToMaybe projectConfigHttpTransport) (flagToMaybe projectConfigIgnoreExpiry) + (fromNubList projectConfigProgPathExtra) -- | Resolve the project configuration, with all its optional fields, into @@ -203,8 +200,8 @@ (getMapMappend projectConfigSpecificPackage) solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion solverSettingSolver = fromFlag projectConfigSolver - solverSettingAllowOlder = fromJust projectConfigAllowOlder - solverSettingAllowNewer = fromJust projectConfigAllowNewer + solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder + solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of n | n < 0 -> Nothing | otherwise -> Just n @@ -212,8 +209,8 @@ solverSettingCountConflicts = fromFlag projectConfigCountConflicts solverSettingStrongFlags = fromFlag projectConfigStrongFlags solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls - solverSettingIndexState = fromFlagOrDefault IndexStateHead projectConfigIndexState - --solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals + solverSettingIndexState = flagToMaybe projectConfigIndexState + solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs --solverSettingReinstall = fromFlag projectConfigReinstall --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls @@ -224,14 +221,14 @@ defaults = mempty { projectConfigSolver = Flag defaultSolver, - projectConfigAllowOlder = Just (AllowOlder RelaxDepsNone), - projectConfigAllowNewer = Just (AllowNewer RelaxDepsNone), + projectConfigAllowOlder = Just (AllowOlder mempty), + projectConfigAllowNewer = Just (AllowNewer mempty), projectConfigMaxBackjumps = Flag defaultMaxBackjumps, projectConfigReorderGoals = Flag (ReorderGoals False), projectConfigCountConflicts = Flag (CountConflicts True), projectConfigStrongFlags = Flag (StrongFlags False), - projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False) - --projectConfigIndependentGoals = Flag (IndependentGoals False), + projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + projectConfigIndependentGoals = Flag (IndependentGoals False) --projectConfigShadowPkgs = Flag False, --projectConfigReinstall = Flag False, --projectConfigAvoidReinstalls = Flag False, @@ -254,7 +251,8 @@ ProjectConfig { projectConfigShared = ProjectConfigShared { projectConfigRemoteRepos, - projectConfigLocalRepos + projectConfigLocalRepos, + projectConfigProgPathExtra }, projectConfigBuildOnly } = @@ -279,6 +277,7 @@ buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry buildSettingReportPlanningFailure = fromFlag projectConfigReportPlanningFailure + buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra ProjectConfigBuildOnly{..} = defaults <> projectConfigBuildOnly @@ -416,9 +415,9 @@ -- | Read all the config relevant for a project. This includes the project -- file if any, plus other global config. -- -readProjectConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig -readProjectConfig verbosity distDirLayout = do - global <- readGlobalConfig verbosity +readProjectConfig :: Verbosity -> Flag FilePath -> DistDirLayout -> Rebuild ProjectConfig +readProjectConfig verbosity configFileFlag distDirLayout = do + global <- readGlobalConfig verbosity configFileFlag local <- readProjectLocalConfig verbosity distDirLayout freeze <- readProjectLocalFreezeConfig verbosity distDirLayout extra <- readProjectLocalExtraConfig verbosity distDirLayout @@ -549,16 +548,13 @@ -- | Read the user's @~/.cabal/config@ file. -- -readGlobalConfig :: Verbosity -> Rebuild ProjectConfig -readGlobalConfig verbosity = do - config <- liftIO (loadConfig verbosity mempty) - configFile <- liftIO defaultConfigFile +readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig +readGlobalConfig verbosity configFileFlag = do + config <- liftIO (loadConfig verbosity configFileFlag) + configFile <- liftIO (getConfigFilePath configFileFlag) monitorFiles [monitorFileHashed configFile] return (convertLegacyGlobalConfig config) - --TODO: do this properly, there's several possible locations - -- and env vars, and flags for selecting the global config - reportParseResult :: Verbosity -> String -> FilePath -> ParseResult a -> IO a reportParseResult verbosity _filetype filename (ParseOk warnings x) = do unless (null warnings) $ @@ -764,29 +760,30 @@ :: String -> Rebuild (Maybe (Either BadPackageLocation [ProjectPackageLocation])) checkIsUriPackage pkglocstr = - return $! case parseAbsoluteURI pkglocstr of Just uri@URI { uriScheme = scheme, - uriAuthority = Just URIAuth { uriRegName = host } + uriAuthority = Just URIAuth { uriRegName = host }, + uriPath = path, + uriQuery = query, + uriFragment = frag } | recognisedScheme && not (null host) -> - Just (Right [ProjectPackageRemoteTarball uri]) + return (Just (Right [ProjectPackageRemoteTarball uri])) - --TODO: [required eventually] handle file: urls which do have a null - -- host. translate URI into filepath and use ProjectPackageLocalTarball - -- or keep as file url and use ProjectPackageRemoteTarball? + | scheme == "file:" && null host && null query && null frag -> + checkIsSingleFilePackage path | not recognisedScheme && not (null host) -> - Just (Left (BadLocUnexpectedUriScheme pkglocstr)) + return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) | recognisedScheme && null host -> - Just (Left (BadLocUnrecognisedUri pkglocstr)) + return (Just (Left (BadLocUnrecognisedUri pkglocstr))) where recognisedScheme = scheme == "http:" || scheme == "https:" || scheme == "file:" - _ -> Nothing + _ -> return Nothing checkIsFileGlobPackage pkglocstr = @@ -894,7 +891,7 @@ -- paths. -- readSourcePackage :: Verbosity -> ProjectPackageLocation - -> Rebuild UnresolvedSourcePackage + -> Rebuild (PackageSpecifier UnresolvedSourcePackage) readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) = readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) where @@ -904,15 +901,27 @@ monitorFiles [monitorFileHashed cabalFile] root <- askRoot pkgdesc <- liftIO $ readGenericPackageDescription verbosity (root cabalFile) - return SourcePackage { + return $ SpecificSourcePackage SourcePackage { packageInfoId = packageId pkgdesc, packageDescription = pkgdesc, packageSource = LocalUnpackedPackage (root dir), packageDescrOverride = Nothing } + +readSourcePackage _ (ProjectPackageNamed (Dependency pkgname verrange)) = + return $ NamedPackage pkgname [PackagePropertyVersion verrange] + readSourcePackage _verbosity _ = fail $ "TODO: add support for fetching and reading local tarballs, remote " ++ "tarballs, remote repos and passing named packages through" + + +-- TODO: add something like this, here or in the project planning +-- Based on the package location, which packages will be built inplace in the +-- build tree vs placed in the store. This has various implications on what we +-- can do with the package, e.g. can we run tests, ghci etc. +-- +-- packageIsLocalToProject :: ProjectPackageLocation -> Bool --------------------------------------------- diff --git a/Distribution/Client/ProjectConfig/Legacy.hs b/Distribution/Client/ProjectConfig/Legacy.hs --- a/Distribution/Client/ProjectConfig/Legacy.hs +++ b/Distribution/Client/ProjectConfig/Legacy.hs @@ -25,7 +25,9 @@ import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types - ( RemoteRepo(..), emptyRemoteRepo ) + ( RemoteRepo(..), emptyRemoteRepo + , AllowNewer(..), AllowOlder(..) ) + import Distribution.Client.Config ( SavedConfig(..), remoteRepoFields ) @@ -33,18 +35,19 @@ import Distribution.Package import Distribution.PackageDescription - ( SourceRepo(..), RepoKind(..) + ( SourceRepo(..), RepoKind(..) , dispFlagAssignment, parseFlagAssignment ) -import Distribution.PackageDescription.Parse +import Distribution.Client.SourceRepoParse ( sourceRepoFieldDescrs ) import Distribution.Simple.Compiler ( OptimisationLevel(..), DebugInfoLevel(..) ) +import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) import Distribution.Simple.Setup ( Flag(Flag), toFlag, fromFlagOrDefault , ConfigFlags(..), configureOptions , HaddockFlags(..), haddockOptions, defaultHaddockFlags , programDbPaths', splitArgs - , AllowNewer(..), AllowOlder(..), RelaxDeps(..) ) + ) import Distribution.Client.Setup ( GlobalFlags(..), globalCommand , ConfigExFlags(..), configureExOptions, defaultConfigExFlags @@ -79,7 +82,6 @@ , OptionField, option, reqArg' ) import qualified Data.Map as Map - ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types -- @@ -100,6 +102,7 @@ legacyPackagesNamed :: [Dependency], legacySharedConfig :: LegacySharedConfig, + legacyAllConfig :: LegacyPackageConfig, legacyLocalConfig :: LegacyPackageConfig, legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig } deriving Generic @@ -163,10 +166,34 @@ projectConfigShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags, - projectConfigLocalPackages = convertLegacyPerPackageFlags - configFlags installFlags haddockFlags + projectConfigLocalPackages = localConfig, + projectConfigAllPackages = allConfig } - + where (localConfig, allConfig) = splitConfig + (convertLegacyPerPackageFlags + configFlags installFlags haddockFlags) + -- split the package config (from command line arguments) into + -- those applied to all packages and those to local only. + -- + -- for now we will just copy over the ProgramPaths/Args/Extra into + -- the AllPackages. The LocalPackages do not inherit them from + -- AllPackages, and as such need to retain them. + -- + -- The general decision rule for what to put into allConfig + -- into localConfig is the following: + -- + -- - anything that is host/toolchain/env specific should be applied + -- to all packages, as packagesets have to be host/toolchain/env + -- consistent. + -- - anything else should be in the local config and could potentially + -- be lifted into all-packages vial the `package *` cabal.project + -- section. + -- + splitConfig :: PackageConfig -> (PackageConfig, PackageConfig) + splitConfig pc = (pc + , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc + , packageConfigProgramArgs = packageConfigProgramArgs pc + , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc }) -- | Convert from the types currently used for the user-wide @~/.cabal/config@ -- file into the 'ProjectConfig' type. @@ -190,9 +217,9 @@ savedHaddockFlags = haddockFlags } = mempty { - projectConfigShared = configAllPackages, - projectConfigLocalPackages = configLocalPackages, - projectConfigBuildOnly = configBuildOnly + projectConfigBuildOnly = configBuildOnly, + projectConfigShared = configShared, + projectConfigAllPackages = configAllPackages } where --TODO: [code cleanup] eliminate use of default*Flags here and specify the @@ -201,9 +228,9 @@ installFlags' = defaultInstallFlags <> installFlags haddockFlags' = defaultHaddockFlags <> haddockFlags - configLocalPackages = convertLegacyPerPackageFlags + configAllPackages = convertLegacyPerPackageFlags configFlags installFlags' haddockFlags' - configAllPackages = convertLegacyAllPackageFlags + configShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags' installFlags' configBuildOnly = convertLegacyBuildOnlyFlags @@ -224,6 +251,7 @@ legacyPackagesNamed, legacySharedConfig = LegacySharedConfig globalFlags configShFlags configExFlags installSharedFlags, + legacyAllConfig, legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags haddockFlags, legacySpecificConfig @@ -236,15 +264,18 @@ projectPackagesNamed = legacyPackagesNamed, projectConfigBuildOnly = configBuildOnly, - projectConfigShared = configAllPackages, + projectConfigShared = configPackagesShared, projectConfigProvenance = mempty, + projectConfigAllPackages = configAllPackages, projectConfigLocalPackages = configLocalPackages, projectConfigSpecificPackage = fmap perPackage legacySpecificConfig } where + configAllPackages = convertLegacyPerPackageFlags g i h + where LegacyPackageConfig g i h = legacyAllConfig configLocalPackages = convertLegacyPerPackageFlags configFlags installPerPkgFlags haddockFlags - configAllPackages = convertLegacyAllPackageFlags + configPackagesShared= convertLegacyAllPackageFlags globalFlags (configFlags <> configShFlags) configExFlags installSharedFlags configBuildOnly = convertLegacyBuildOnlyFlags @@ -268,29 +299,31 @@ ProjectConfigShared{..} where GlobalFlags { - globalConfigFile = _, -- TODO: [required feature] + globalConfigFile = projectConfigConfigFile, globalSandboxConfigFile = _, -- ?? globalRemoteRepos = projectConfigRemoteRepos, - globalLocalRepos = projectConfigLocalRepos + globalLocalRepos = projectConfigLocalRepos, + globalProgPathExtra = projectConfigProgPathExtra } = globalFlags ConfigFlags { configDistPref = projectConfigDistDir, configHcFlavor = projectConfigHcFlavor, configHcPath = projectConfigHcPath, - configHcPkg = projectConfigHcPkg, + configHcPkg = projectConfigHcPkg + --configProgramPathExtra = projectConfigProgPathExtra DELETE ME --configInstallDirs = projectConfigInstallDirs, --configUserInstall = projectConfigUserInstall, --configPackageDBs = projectConfigPackageDBs, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer } = configFlags ConfigExFlags { configCabalVersion = projectConfigCabalVersion, configExConstraints = projectConfigConstraints, configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver + configSolver = projectConfigSolver, + configAllowOlder = projectConfigAllowOlder, + configAllowNewer = projectConfigAllowNewer } = configExFlags InstallFlags { @@ -305,7 +338,7 @@ installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, installPerComponent = projectConfigPerComponent, - --installIndependentGoals = projectConfigIndependentGoals, + installIndependentGoals = projectConfigIndependentGoals, --installShadowPkgs = projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, installAllowBootLibInstalls = projectConfigAllowBootLibInstalls @@ -328,6 +361,7 @@ configVanillaLib = packageConfigVanillaLib, configProfLib = packageConfigProfLib, configSharedLib = packageConfigSharedLib, + configStaticLib = packageConfigStaticLib, configDynExe = packageConfigDynExe, configProfExe = packageConfigProfExe, configProf = packageConfigProf, @@ -338,6 +372,7 @@ configProgPrefix = packageConfigProgPrefix, configProgSuffix = packageConfigProgSuffix, configGHCiLib = packageConfigGHCiLib, + configSplitSections = packageConfigSplitSections, configSplitObjs = packageConfigSplitObjs, configStripExes = packageConfigStripExes, configStripLibs = packageConfigStripLibs, @@ -368,12 +403,13 @@ haddockHtml = packageConfigHaddockHtml, haddockHtmlLocation = packageConfigHaddockHtmlLocation, haddockForeignLibs = packageConfigHaddockForeignLibs, + haddockForHackage = packageConfigHaddockForHackage, haddockExecutables = packageConfigHaddockExecutables, haddockTestSuites = packageConfigHaddockTestSuites, haddockBenchmarks = packageConfigHaddockBenchmarks, haddockInternal = packageConfigHaddockInternal, haddockCss = packageConfigHaddockCss, - haddockHscolour = packageConfigHaddockHscolour, + haddockLinkedSource = packageConfigHaddockLinkedSource, haddockHscolourCss = packageConfigHaddockHscolourCss, haddockContents = packageConfigHaddockContents } = haddockFlags @@ -431,6 +467,7 @@ projectPackagesOptional, projectPackagesRepo, projectPackagesNamed, + projectConfigAllPackages, projectConfigLocalPackages, projectConfigSpecificPackage } = @@ -440,6 +477,8 @@ legacyPackagesRepo = projectPackagesRepo, legacyPackagesNamed = projectPackagesNamed, legacySharedConfig = convertToLegacySharedConfig projectConfig, + legacyAllConfig = convertToLegacyPerPackageConfig + projectConfigAllPackages, legacyLocalConfig = convertToLegacyAllPackageConfig projectConfig <> convertToLegacyPerPackageConfig projectConfigLocalPackages, @@ -451,7 +490,10 @@ convertToLegacySharedConfig ProjectConfig { projectConfigBuildOnly = ProjectConfigBuildOnly {..}, - projectConfigShared = ProjectConfigShared {..} + projectConfigShared = ProjectConfigShared {..}, + projectConfigAllPackages = PackageConfig { + packageConfigDocumentation + } } = LegacySharedConfig { @@ -464,7 +506,7 @@ globalFlags = GlobalFlags { globalVersion = mempty, globalNumericVersion = mempty, - globalConfigFile = mempty, + globalConfigFile = projectConfigConfigFile, globalSandboxConfigFile = mempty, globalConstraintsFile = mempty, globalRemoteRepos = projectConfigRemoteRepos, @@ -477,26 +519,29 @@ globalIgnoreExpiry = projectConfigIgnoreExpiry, globalHttpTransport = projectConfigHttpTransport, globalNix = mempty, - globalStoreDir = projectConfigStoreDir + globalStoreDir = projectConfigStoreDir, + globalProgPathExtra = projectConfigProgPathExtra } configFlags = mempty { configVerbosity = projectConfigVerbosity, - configDistPref = projectConfigDistDir, - configAllowOlder = projectConfigAllowOlder, - configAllowNewer = projectConfigAllowNewer + configDistPref = projectConfigDistDir } configExFlags = ConfigExFlags { configCabalVersion = projectConfigCabalVersion, configExConstraints = projectConfigConstraints, configPreferences = projectConfigPreferences, - configSolver = projectConfigSolver + configSolver = projectConfigSolver, + configAllowOlder = projectConfigAllowOlder, + configAllowNewer = projectConfigAllowNewer + } installFlags = InstallFlags { - installDocumentation = mempty, + installDocumentation = packageConfigDocumentation, installHaddockIndex = projectConfigHaddockIndex, + installDest = Flag NoCopyDest, installDryRun = projectConfigDryRun, installReinstall = mempty, --projectConfigReinstall, installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls, @@ -505,7 +550,7 @@ installUpgradeDeps = mempty, --projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, - installIndependentGoals = mempty, --projectConfigIndependentGoals, + installIndependentGoals = projectConfigIndependentGoals, installShadowPkgs = mempty, --projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, @@ -554,6 +599,7 @@ configVanillaLib = mempty, configProfLib = mempty, configSharedLib = mempty, + configStaticLib = mempty, configDynExe = mempty, configProfExe = mempty, configProf = mempty, @@ -571,6 +617,7 @@ configUserInstall = mempty, --projectConfigUserInstall, configPackageDBs = mempty, --projectConfigPackageDBs, configGHCiLib = mempty, + configSplitSections = mempty, configSplitObjs = mempty, configStripExes = mempty, configStripLibs = mempty, @@ -591,8 +638,7 @@ configFlagError = mempty, --TODO: ??? configRelocatable = mempty, configDebugInfo = mempty, - configAllowOlder = mempty, - configAllowNewer = mempty + configUseResponseFiles = mempty } haddockFlags = mempty { @@ -621,6 +667,7 @@ configVanillaLib = packageConfigVanillaLib, configProfLib = packageConfigProfLib, configSharedLib = packageConfigSharedLib, + configStaticLib = packageConfigStaticLib, configDynExe = packageConfigDynExe, configProfExe = packageConfigProfExe, configProf = packageConfigProf, @@ -638,6 +685,7 @@ configUserInstall = mempty, configPackageDBs = mempty, configGHCiLib = packageConfigGHCiLib, + configSplitSections = packageConfigSplitSections, configSplitObjs = packageConfigSplitObjs, configStripExes = packageConfigStripExes, configStripLibs = packageConfigStripLibs, @@ -658,8 +706,7 @@ configFlagError = mempty, --TODO: ??? configRelocatable = packageConfigRelocatable, configDebugInfo = packageConfigDebugInfo, - configAllowOlder = mempty, - configAllowNewer = mempty + configUseResponseFiles = mempty } installFlags = mempty { @@ -673,19 +720,20 @@ haddockHoogle = packageConfigHaddockHoogle, haddockHtml = packageConfigHaddockHtml, haddockHtmlLocation = packageConfigHaddockHtmlLocation, - haddockForHackage = mempty, --TODO: added recently + haddockForHackage = packageConfigHaddockForHackage, haddockForeignLibs = packageConfigHaddockForeignLibs, haddockExecutables = packageConfigHaddockExecutables, haddockTestSuites = packageConfigHaddockTestSuites, haddockBenchmarks = packageConfigHaddockBenchmarks, haddockInternal = packageConfigHaddockInternal, haddockCss = packageConfigHaddockCss, - haddockHscolour = packageConfigHaddockHscolour, + haddockLinkedSource = packageConfigHaddockLinkedSource, haddockHscolourCss = packageConfigHaddockHscolourCss, haddockContents = packageConfigHaddockContents, haddockDistPref = mempty, haddockKeepTempFiles = mempty, - haddockVerbosity = mempty + haddockVerbosity = mempty, + haddockCabalFilePath = mempty } @@ -798,7 +846,11 @@ [ newLineListField "local-repo" showTokenQ parseTokenQ (fromNubList . globalLocalRepos) - (\v conf -> conf { globalLocalRepos = toNubList v }) + (\v conf -> conf { globalLocalRepos = toNubList v }), + newLineListField "extra-prog-path-shared-only" + showTokenQ parseTokenQ + (fromNubList . globalProgPathExtra) + (\v conf -> conf { globalProgPathExtra = toNubList v }) ] . filterFields [ "remote-repo-cache" @@ -810,18 +862,6 @@ ( liftFields legacyConfigureShFlags (\flags conf -> conf { legacyConfigureShFlags = flags }) - . addFields - [ monoidField "allow-older" - (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps) - (fmap unAllowOlder . configAllowOlder) - (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) - ] - . addFields - [ monoidField "allow-newer" - (maybe mempty dispRelaxDeps) (fmap Just parseRelaxDeps) - (fmap unAllowNewer . configAllowNewer) - (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) - ] . filterFields ["verbose", "builddir" ] . commandOptionsToFields ) (configureOptions ParseArgs) @@ -837,6 +877,16 @@ , commaNewLineListField "preferences" disp parse configPreferences (\v conf -> conf { configPreferences = v }) + + , monoidField "allow-older" + (maybe mempty disp) (fmap Just parse) + (fmap unAllowOlder . configAllowOlder) + (\v conf -> conf { configAllowOlder = fmap AllowOlder v }) + + , monoidField "allow-newer" + (maybe mempty disp) (fmap Just parse) + (fmap unAllowNewer . configAllowNewer) + (\v conf -> conf { configAllowNewer = fmap AllowNewer v }) ] . filterFields [ "cabal-lib-version", "solver" @@ -861,27 +911,15 @@ , "remote-build-reporting", "report-planning-failure" , "one-shot", "jobs", "keep-going", "offline", "per-component" -- solver flags: - , "max-backjumps", "reorder-goals", "count-conflicts", "strong-flags" - , "allow-boot-library-installs", "index-state" + , "max-backjumps", "reorder-goals", "count-conflicts", "independent-goals" + , "strong-flags" , "allow-boot-library-installs", "index-state" ] . commandOptionsToFields ) (installOptions ParseArgs) where constraintSrc = ConstraintSourceProjectConfig "TODO" -parseRelaxDeps :: ReadP r RelaxDeps -parseRelaxDeps = - ((const RelaxDepsNone <$> (Parse.string "none" +++ Parse.string "None")) - +++ (const RelaxDepsAll <$> (Parse.string "all" +++ Parse.string "All"))) - <++ ( RelaxDepsSome <$> parseOptCommaList parse) -dispRelaxDeps :: RelaxDeps -> Doc -dispRelaxDeps RelaxDepsNone = Disp.text "None" -dispRelaxDeps (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma - . map disp $ pkgs -dispRelaxDeps RelaxDepsAll = Disp.text "All" - - legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig] legacyPackageConfigFieldDescrs = ( liftFields @@ -917,10 +955,10 @@ [ "with-compiler", "with-hc-pkg" , "program-prefix", "program-suffix" , "library-vanilla", "library-profiling" - , "shared", "executable-dynamic" + , "shared", "static", "executable-dynamic" , "profiling", "executable-profiling" , "profiling-detail", "library-profiling-detail" - , "library-for-ghci", "split-objs" + , "library-for-ghci", "split-objs", "split-sections" , "executable-stripping", "library-stripping" , "tests", "benchmarks" , "coverage", "library-coverage" @@ -954,6 +992,12 @@ (\flags conf -> conf { legacyHaddockFlags = flags }) . mapFieldNames ("haddock-"++) + . addFields + [ simpleField "for-hackage" + -- TODO: turn this into a library function + (fromFlagOrDefault Disp.empty . fmap disp) (Parse.option mempty (fmap toFlag parse)) + haddockForHackage (\v conf -> conf { haddockForHackage = v }) + ] . filterFields [ "hoogle", "html", "html-location" , "foreign-libraries" @@ -1074,45 +1118,61 @@ } } +-- | The definitions of all the fields that can appear in the @package pkgfoo@ +-- and @package *@ sections of the @cabal.project@-format files. +-- +packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig] +packageSpecificOptionsFieldDescrs = + legacyPackageConfigFieldDescrs + ++ programOptionsFieldDescrs + (configProgramArgs . legacyConfigureFlags) + (\args pkgconf -> pkgconf { + legacyConfigureFlags = (legacyConfigureFlags pkgconf) { + configProgramArgs = args + } + } + ) + ++ liftFields + legacyConfigureFlags + (\flags pkgconf -> pkgconf { + legacyConfigureFlags = flags + } + ) + programLocationsFieldDescrs + +-- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format +-- files. This section is per-package name. The special package @*@ applies to all +-- packages used anywhere by the project, locally or as dependencies. +-- packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig packageSpecificOptionsSectionDescr = SectionDescr { sectionName = "package", - sectionFields = legacyPackageConfigFieldDescrs - ++ programOptionsFieldDescrs - (configProgramArgs . legacyConfigureFlags) - (\args pkgconf -> pkgconf { - legacyConfigureFlags = (legacyConfigureFlags pkgconf) { - configProgramArgs = args - } - } - ) - ++ liftFields - legacyConfigureFlags - (\flags pkgconf -> pkgconf { - legacyConfigureFlags = flags - } - ) - programLocationsFieldDescrs, + sectionFields = packageSpecificOptionsFieldDescrs, sectionSubsections = [], sectionGet = \projconf -> [ (display pkgname, pkgconf) | (pkgname, pkgconf) <- Map.toList . getMapMappend - . legacySpecificConfig $ projconf ], + . legacySpecificConfig $ projconf ] + ++ [ ("*", legacyAllConfig projconf) ], sectionSet = - \lineno pkgnamestr pkgconf projconf -> do - pkgname <- case simpleParse pkgnamestr of - Just pkgname -> return pkgname - Nothing -> syntaxError lineno $ - "a 'package' section requires a package name " - ++ "as an argument" - return projconf { - legacySpecificConfig = - MapMappend $ - Map.insertWith mappend pkgname pkgconf - (getMapMappend $ legacySpecificConfig projconf) - }, + \lineno pkgnamestr pkgconf projconf -> case pkgnamestr of + "*" -> return projconf { + legacyAllConfig = legacyAllConfig projconf <> pkgconf + } + _ -> do + pkgname <- case simpleParse pkgnamestr of + Just pkgname -> return pkgname + Nothing -> syntaxError lineno $ + "a 'package' section requires a package name " + ++ "as an argument" + return projconf { + legacySpecificConfig = + MapMappend $ + Map.insertWith mappend pkgname pkgconf + (getMapMappend $ legacySpecificConfig projconf) + }, sectionEmpty = mempty } diff --git a/Distribution/Client/ProjectConfig/Types.hs b/Distribution/Client/ProjectConfig/Types.hs --- a/Distribution/Client/ProjectConfig/Types.hs +++ b/Distribution/Client/ProjectConfig/Types.hs @@ -21,7 +21,7 @@ ) where import Distribution.Client.Types - ( RemoteRepo ) + ( RemoteRepo, AllowNewer(..), AllowOlder(..) ) import Distribution.Client.Dependency.Types ( PreSolver ) import Distribution.Client.Targets @@ -48,7 +48,7 @@ ( Compiler, CompilerFlavor , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) import Distribution.Simple.Setup - ( Flag, AllowNewer(..), AllowOlder(..) ) + ( Flag, HaddockTarget(..) ) import Distribution.Simple.InstallDirs ( PathTemplate ) import Distribution.Utils.NubList @@ -113,6 +113,10 @@ projectConfigShared :: ProjectConfigShared, projectConfigProvenance :: Set ProjectConfigProvenance, + -- | Configuration to be applied to *all* packages, + -- whether named in `cabal.project` or not. + projectConfigAllPackages :: PackageConfig, + -- | Configuration to be applied to *local* packages; i.e., -- any packages which are explicitly named in `cabal.project`. projectConfigLocalPackages :: PackageConfig, @@ -155,6 +159,7 @@ data ProjectConfigShared = ProjectConfigShared { projectConfigDistDir :: Flag FilePath, + projectConfigConfigFile :: Flag FilePath, projectConfigProjectFile :: Flag FilePath, projectConfigHcFlavor :: Flag CompilerFlavor, projectConfigHcPath :: Flag FilePath, @@ -186,11 +191,13 @@ projectConfigCountConflicts :: Flag CountConflicts, projectConfigStrongFlags :: Flag StrongFlags, projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, - projectConfigPerComponent :: Flag Bool + projectConfigPerComponent :: Flag Bool, + projectConfigIndependentGoals :: Flag IndependentGoals, + projectConfigProgPathExtra :: NubList FilePath + -- More things that only make sense for manual mode, not --local mode -- too much control! - --projectConfigIndependentGoals :: Flag IndependentGoals, --projectConfigShadowPkgs :: Flag Bool, --projectConfigReinstall :: Flag Bool, --projectConfigAvoidReinstalls :: Flag Bool, @@ -227,6 +234,7 @@ packageConfigFlagAssignment :: FlagAssignment, packageConfigVanillaLib :: Flag Bool, packageConfigSharedLib :: Flag Bool, + packageConfigStaticLib :: Flag Bool, packageConfigDynExe :: Flag Bool, packageConfigProf :: Flag Bool, --TODO: [code cleanup] sort out packageConfigProfLib :: Flag Bool, -- this duplication @@ -241,6 +249,7 @@ packageConfigExtraFrameworkDirs :: [FilePath], packageConfigExtraIncludeDirs :: [FilePath], packageConfigGHCiLib :: Flag Bool, + packageConfigSplitSections :: Flag Bool, packageConfigSplitObjs :: Flag Bool, packageConfigStripExes :: Flag Bool, packageConfigStripLibs :: Flag Bool, @@ -260,9 +269,10 @@ packageConfigHaddockBenchmarks :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockInternal :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockCss :: Flag FilePath, --TODO: [required eventually] use this - packageConfigHaddockHscolour :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this - packageConfigHaddockContents :: Flag PathTemplate --TODO: [required eventually] use this + packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this + packageConfigHaddockForHackage :: Flag HaddockTarget } deriving (Eq, Show, Generic) @@ -283,7 +293,7 @@ mappend = (<>) instance Ord k => Semigroup (MapLast k v) where - MapLast a <> MapLast b = MapLast (flip Map.union a b) + MapLast a <> MapLast b = MapLast $ Map.union b a -- rather than Map.union which is the normal Map monoid instance @@ -361,10 +371,10 @@ solverSettingCountConflicts :: CountConflicts, solverSettingStrongFlags :: StrongFlags, solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, - solverSettingIndexState :: IndexState + solverSettingIndexState :: Maybe IndexState, + solverSettingIndependentGoals :: IndependentGoals -- Things that only make sense for manual mode, not --local mode -- too much control! - --solverSettingIndependentGoals :: IndependentGoals, --solverSettingShadowPkgs :: Bool, --solverSettingReinstall :: Bool, --solverSettingAvoidReinstalls :: Bool, @@ -406,6 +416,6 @@ buildSettingLocalRepos :: [FilePath], buildSettingCacheDir :: FilePath, buildSettingHttpTransport :: Maybe String, - buildSettingIgnoreExpiry :: Bool + buildSettingIgnoreExpiry :: Bool, + buildSettingProgPathExtra :: [FilePath] } - diff --git a/Distribution/Client/ProjectOrchestration.hs b/Distribution/Client/ProjectOrchestration.hs --- a/Distribution/Client/ProjectOrchestration.hs +++ b/Distribution/Client/ProjectOrchestration.hs @@ -4,7 +4,7 @@ -- | This module deals with building and incrementally rebuilding a collection -- of packages. It is what backs the @cabal build@ and @configure@ commands, --- as well as being a core part of @run@, @test@, @bench@ and others. +-- as well as being a core part of @run@, @test@, @bench@ and others. -- -- The primary thing is in fact rebuilding (and trying to make that quick by -- not redoing unnecessary work), so building from scratch is just a special @@ -33,7 +33,7 @@ -- This division helps us keep the code under control, making it easier to -- understand, test and debug. So when you are extending these modules, please -- think about which parts of your change belong in which part. It is --- perfectly ok to extend the description of what to do (i.e. the +-- perfectly ok to extend the description of what to do (i.e. the -- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the -- first phase. Also, the second phase does not have direct access to any of -- the input configuration anyway; all the information has to flow via the @@ -94,6 +94,9 @@ cmdCommonHelpTextNewBuildBeta, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning hiding ( pruneInstallPlanToTargets ) @@ -104,7 +107,8 @@ import Distribution.Client.ProjectPlanOutput import Distribution.Client.Types - ( GenericReadyPackage(..), UnresolvedSourcePackage ) + ( GenericReadyPackage(..), UnresolvedSourcePackage + , PackageSpecifier(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.TargetSelector ( TargetSelector(..) @@ -113,29 +117,36 @@ import Distribution.Client.DistDirLayout import Distribution.Client.Config (defaultCabalDir) import Distribution.Client.Setup hiding (packageName) +import Distribution.Types.ComponentName + ( componentNameString ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, packageNameToUnqualComponentName ) import Distribution.Solver.Types.OptionalStanza import Distribution.Package hiding (InstalledPackageId, installedPackageId) -import Distribution.PackageDescription (FlagAssignment, showFlagValue) +import Distribution.PackageDescription + ( FlagAssignment, unFlagAssignment, showFlagValue + , diffFlagAssignment ) import Distribution.Simple.LocalBuildInfo ( ComponentName(..), pkgComponents ) import qualified Distribution.Simple.Setup as Setup import Distribution.Simple.Command (commandShowOptions) +import Distribution.Simple.Configure (computeEffectiveProfiling) import Distribution.Simple.Utils ( die' , notice, noticeNoWrap, debugNoWrap ) import Distribution.Verbosity import Distribution.Text +import Distribution.Simple.Compiler + ( showCompilerId + , OptimisationLevel(..)) import qualified Data.Monoid as Mon import qualified Data.Set as Set import qualified Data.Map as Map -import Data.Map (Map) -import Data.List -import Data.Maybe import Data.Either import Control.Exception (Exception(..), throwIO, assert) import System.Exit (ExitCode(..), exitFailure) @@ -151,7 +162,7 @@ distDirLayout :: DistDirLayout, cabalDirLayout :: CabalDirLayout, projectConfig :: ProjectConfig, - localPackages :: [UnresolvedSourcePackage], + localPackages :: [PackageSpecifier UnresolvedSourcePackage], buildSettings :: BuildTimeSettings } @@ -222,7 +233,11 @@ -- | The result of the dry-run phase. This tells us about each member of -- the 'elaboratedPlanToExecute'. - pkgsBuildStatus :: BuildStatusMap + pkgsBuildStatus :: BuildStatusMap, + + -- | The targets selected by @selectPlanSubset@. This is useful eg. in + -- CmdRun, where we need a valid target to execute. + targetsMap :: TargetsMap } @@ -231,7 +246,7 @@ runProjectPreBuildPhase :: Verbosity -> ProjectBaseContext - -> (ElaboratedInstallPlan -> IO ElaboratedInstallPlan) + -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) -> IO ProjectBuildContext runProjectPreBuildPhase verbosity @@ -258,7 +273,7 @@ -- Now given the specific targets the user has asked for, decide -- which bits of the plan we will want to execute. -- - elaboratedPlan' <- selectPlanSubset elaboratedPlan + (elaboratedPlan', targets) <- selectPlanSubset elaboratedPlan -- Check which packages need rebuilding. -- This also gives us more accurate reasons for the --dry-run output. @@ -276,7 +291,8 @@ elaboratedPlanOriginal = elaboratedPlan, elaboratedPlanToExecute = elaboratedPlan'', elaboratedShared, - pkgsBuildStatus + pkgsBuildStatus, + targetsMap = targets } @@ -341,10 +357,11 @@ pkgsBuildStatus buildOutcomes - writePlanGhcEnvironment distDirLayout - elaboratedPlanOriginal - elaboratedShared - postBuildStatus + void $ writePlanGhcEnvironment (distProjectRootDirectory + distDirLayout) + elaboratedPlanOriginal + elaboratedShared + postBuildStatus -- Finally if there were any build failures then report them and throw -- an exception to terminate the program @@ -364,7 +381,7 @@ -- on it) all go into the install plan. -- Notionally, the 'BuildFlags' should be things that do not affect what - -- we build, just how we do it. These ones of course do + -- we build, just how we do it. These ones of course do ------------------------------------------------------------------------------ @@ -380,7 +397,7 @@ -- possible to for different selectors to match the same target. This extra -- information is primarily to help make helpful error messages. -- -type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector PackageId])] +type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector])] -- | Given a set of 'TargetSelector's, resolve which 'UnitId's and -- 'ComponentTarget's they ought to refer to. @@ -415,18 +432,18 @@ -- a basis for their own @selectComponentTarget@ implementation. -- resolveTargets :: forall err. - (forall k. TargetSelector PackageId + (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) - -> (forall k. PackageId -> ComponentName -> SubComponentTarget + -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) -> ElaboratedInstallPlan - -> [TargetSelector PackageId] + -> [TargetSelector] -> Either [err] TargetsMap resolveTargets selectPackageTargets selectComponentTarget liftProblem - installPlan targetSelectors = + installPlan = --TODO: [required eventually] -- we cannot resolve names of packages other than those that are -- directly in the current plan. We ought to keep a set of the known @@ -434,72 +451,171 @@ -- really need that until we can do something sensible with packages -- outside of the project. - case partitionEithers - [ fmap ((,) targetSelector) (checkTarget targetSelector) - | targetSelector <- targetSelectors ] of - ([], targets) -> Right - . Map.map nubComponentTargets - $ Map.fromListWith (++) - [ (uid, [(ct, ts)]) - | (ts, cts) <- targets - , (uid, ct) <- cts ] - - (problems, _) -> Left problems + fmap mkTargetsMap + . checkErrors + . map (\ts -> (,) ts <$> checkTarget ts) where - -- TODO [required eventually] currently all build targets refer to packages - -- inside the project. Ultimately this has to be generalised to allow - -- referring to other packages and targets. - checkTarget :: TargetSelector PackageId - -> Either err [(UnitId, ComponentTarget)] + mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])] + -> TargetsMap + mkTargetsMap targets = + Map.map nubComponentTargets + $ Map.fromListWith (++) + [ (uid, [(ct, ts)]) + | (ts, cts) <- targets + , (uid, ct) <- cts ] + AvailableTargetIndexes{..} = availableTargetIndexes installPlan + + checkTarget :: TargetSelector -> Either err [(UnitId, ComponentTarget)] + -- We can ask to build any whole package, project-local or a dependency - checkTarget bt@(TargetPackage _ pkgid mkfilter) + checkTarget bt@(TargetPackage _ [pkgid] mkfilter) | Just ats <- fmap (maybe id filterTargetsKind mkfilter) - $ Map.lookup pkgid availableTargetsByPackage - = case selectPackageTargets bt ats of - Left e -> Left e - Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) - | (unitid, cname) <- ts ] + $ Map.lookup pkgid availableTargetsByPackageId + = fmap (componentTargets WholeComponent) + $ selectPackageTargets bt ats | otherwise = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) + checkTarget (TargetPackage _ _ _) + = error "TODO: add support for multiple packages in a directory" + -- For the moment this error cannot happen here, because it gets + -- detected when the package config is being constructed. This case + -- will need handling properly when we do add support. + -- + -- TODO: how should this use case play together with the + -- '--cabal-file' option of 'configure' which allows using multiple + -- .cabal files for a single package? + checkTarget bt@(TargetAllPackages mkfilter) = - let ats = maybe id filterTargetsKind mkfilter - $ filter availableTargetLocalToProject - $ concat (Map.elems availableTargetsByPackage) - in case selectPackageTargets bt ats of - Left e -> Left e - Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) - | (unitid, cname) <- ts ] + fmap (componentTargets WholeComponent) + . selectPackageTargets bt + . maybe id filterTargetsKind mkfilter + . filter availableTargetLocalToProject + $ concat (Map.elems availableTargetsByPackageId) checkTarget (TargetComponent pkgid cname subtarget) - | Just ats <- Map.lookup (pkgid, cname) availableTargetsByComponent - = case partitionEithers - (map (selectComponentTarget pkgid cname subtarget) ats) of - (e:_,_) -> Left e - ([],ts) -> Right [ (unitid, ctarget) - | let ctarget = ComponentTarget cname subtarget - , (unitid, _) <- ts ] + | Just ats <- Map.lookup (pkgid, cname) + availableTargetsByPackageIdAndComponentName + = fmap (componentTargets subtarget) + $ selectComponentTargets subtarget ats - | Map.member pkgid availableTargetsByPackage + | Map.member pkgid availableTargetsByPackageId = Left (liftProblem (TargetProblemNoSuchComponent pkgid cname)) | otherwise = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) - --TODO: check if the package is in the plan, even if it's not local + checkTarget (TargetComponentUnknown pkgname ecname subtarget) + | Just ats <- case ecname of + Left ucname -> + Map.lookup (pkgname, ucname) + availableTargetsByPackageNameAndUnqualComponentName + Right cname -> + Map.lookup (pkgname, cname) + availableTargetsByPackageNameAndComponentName + = fmap (componentTargets subtarget) + $ selectComponentTargets subtarget ats + + | Map.member pkgname availableTargetsByPackageName + = Left (liftProblem (TargetProblemUnknownComponent pkgname ecname)) + + | otherwise + = Left (liftProblem (TargetNotInProject pkgname)) + + checkTarget bt@(TargetPackageNamed pkgname mkfilter) + | Just ats <- fmap (maybe id filterTargetsKind mkfilter) + $ Map.lookup pkgname availableTargetsByPackageName + = fmap (componentTargets WholeComponent) + . selectPackageTargets bt + $ ats + + | otherwise + = Left (liftProblem (TargetNotInProject pkgname)) --TODO: check if the package is in hackage and return different -- error cases here so the commands can handle things appropriately - availableTargetsByPackage :: Map PackageId [AvailableTarget (UnitId, ComponentName)] - availableTargetsByComponent :: Map (PackageId, ComponentName) [AvailableTarget (UnitId, ComponentName)] - availableTargetsByComponent = availableTargets installPlan - availableTargetsByPackage = Map.mapKeysWith - (++) (\(pkgid, _cname) -> pkgid) - availableTargetsByComponent - `Map.union` availableTargetsEmptyPackages + componentTargets :: SubComponentTarget + -> [(b, ComponentName)] + -> [(b, ComponentTarget)] + componentTargets subtarget = + map (fmap (\cname -> ComponentTarget cname subtarget)) + selectComponentTargets :: SubComponentTarget + -> [AvailableTarget k] + -> Either err [k] + selectComponentTargets subtarget = + either (Left . head) Right + . checkErrors + . map (selectComponentTarget subtarget) + + checkErrors :: [Either e a] -> Either [e] [a] + checkErrors = (\(es, xs) -> if null es then Right xs else Left es) + . partitionEithers + + +data AvailableTargetIndexes = AvailableTargetIndexes { + availableTargetsByPackageIdAndComponentName + :: AvailableTargetsMap (PackageId, ComponentName), + + availableTargetsByPackageId + :: AvailableTargetsMap PackageId, + + availableTargetsByPackageName + :: AvailableTargetsMap PackageName, + + availableTargetsByPackageNameAndComponentName + :: AvailableTargetsMap (PackageName, ComponentName), + + availableTargetsByPackageNameAndUnqualComponentName + :: AvailableTargetsMap (PackageName, UnqualComponentName) + } +type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)] + +-- We define a bunch of indexes to help 'resolveTargets' with resolving +-- 'TargetSelector's to specific 'UnitId's. +-- +-- They are all derived from the 'availableTargets' index. +-- The 'availableTargetsByPackageIdAndComponentName' is just that main index, +-- while the others are derived by re-grouping on the index key. +-- +-- They are all constructed lazily because they are not necessarily all used. +-- +availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes +availableTargetIndexes installPlan = AvailableTargetIndexes{..} + where + availableTargetsByPackageIdAndComponentName = + availableTargets installPlan + + availableTargetsByPackageId = + Map.mapKeysWith + (++) (\(pkgid, _cname) -> pkgid) + availableTargetsByPackageIdAndComponentName + `Map.union` availableTargetsEmptyPackages + + availableTargetsByPackageName = + Map.mapKeysWith + (++) packageName + availableTargetsByPackageId + + availableTargetsByPackageNameAndComponentName = + Map.mapKeysWith + (++) (\(pkgid, cname) -> (packageName pkgid, cname)) + availableTargetsByPackageIdAndComponentName + + availableTargetsByPackageNameAndUnqualComponentName = + Map.mapKeysWith + (++) (\(pkgid, cname) -> let pname = packageName pkgid + cname' = unqualComponentName pname cname + in (pname, cname')) + availableTargetsByPackageIdAndComponentName + where + unqualComponentName :: PackageName -> ComponentName -> UnqualComponentName + unqualComponentName pkgname = + fromMaybe (packageNameToUnqualComponentName pkgname) + . componentNameString + -- Add in all the empty packages. These do not appear in the -- availableTargetsByComponent map, since that only contains components -- so packages with no components are invisible from that perspective. @@ -562,12 +678,15 @@ -- buildable and isn't a test suite or benchmark that is disabled. This -- can also be used to do these basic checks as part of a custom impl that -- -selectComponentTargetBasic :: PackageId - -> ComponentName - -> SubComponentTarget +selectComponentTargetBasic :: SubComponentTarget -> AvailableTarget k -> Either TargetProblemCommon k -selectComponentTargetBasic pkgid cname subtarget AvailableTarget {..} = +selectComponentTargetBasic subtarget + AvailableTarget { + availableTargetPackageId = pkgid, + availableTargetComponentName = cname, + availableTargetStatus + } = case availableTargetStatus of TargetDisabledByUser -> Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget) @@ -590,6 +709,8 @@ | TargetComponentNotBuildable PackageId ComponentName SubComponentTarget | TargetOptionalStanzaDisabledByUser PackageId ComponentName SubComponentTarget | TargetOptionalStanzaDisabledBySolver PackageId ComponentName SubComponentTarget + | TargetProblemUnknownComponent PackageName + (Either UnqualComponentName ComponentName) -- The target matching stuff only returns packages local to the project, -- so these lookups should never fail, but if 'resolveTargets' is called @@ -633,7 +754,10 @@ -> IO () printPlan verbosity ProjectBaseContext { - buildSettings = BuildTimeSettings{buildSettingDryRun} + buildSettings = BuildTimeSettings{buildSettingDryRun}, + projectConfig = ProjectConfig { + projectConfigLocalPackages = PackageConfig {packageConfigOptimization} + } } ProjectBuildContext { elaboratedPlanToExecute = elaboratedPlan, @@ -646,7 +770,7 @@ | otherwise = noticeNoWrap verbosity $ unlines $ - ("In order, the following " ++ wouldWill ++ " be built" ++ + (showBuildProfile ++ "In order, the following " ++ wouldWill ++ " be built" ++ ifNormal " (use -v for more details)" ++ ":") : map showPkgAndReason pkgs @@ -690,7 +814,7 @@ | (k,v) <- Map.toList (elabInstantiatedWith elab) ] nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment - nonDefaultFlags elab = elabFlagAssignment elab \\ elabFlagDefaults elab + nonDefaultFlags elab = elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab showStanzas pkg = concat $ [ " *test" @@ -705,7 +829,7 @@ ++ ")" showFlagAssignment :: FlagAssignment -> String - showFlagAssignment = concatMap ((' ' :) . showFlagValue) + showFlagAssignment = concatMap ((' ' :) . showFlagValue) . unFlagAssignment showConfigureFlags elab = let fullConfigureFlags @@ -720,12 +844,7 @@ nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag nubFlag _ f = f - -- TODO: Closely logic from 'configureProfiling'. - tryExeProfiling = Setup.fromFlagOrDefault False - (configProf fullConfigureFlags) - tryLibProfiling = Setup.fromFlagOrDefault False - (Mon.mappend (configProf fullConfigureFlags) - (configProfExe fullConfigureFlags)) + (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling fullConfigureFlags partialConfigureFlags = Mon.mempty { configProf = @@ -764,6 +883,14 @@ showMonitorChangedReason MonitorFirstRun = "first run" showMonitorChangedReason MonitorCorruptCache = "cannot read state cache" + showBuildProfile = "Build profile: " ++ unwords [ + "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared, + "-O" ++ (case packageConfigOptimization of + Setup.Flag NoOptimisation -> "0" + Setup.Flag NormalOptimisation -> "1" + Setup.Flag MaximumOptimisation -> "2" + Setup.NoFlag -> "1")] + ++ "\n" -- | If there are build failures then report them and throw an exception. -- @@ -885,6 +1012,7 @@ ReplFailed _ -> "repl failed for " ++ pkgstr HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr TestsFailed _ -> "Tests failed for " ++ pkgstr + BenchFailed _ -> "Benchmarks failed for " ++ pkgstr InstallFailed _ -> "Failed to build " ++ pkgstr DependentFailed depid -> "Failed to build " ++ display (packageId pkg) @@ -968,6 +1096,7 @@ ReplFailed e -> Just e HaddocksFailed e -> Just e TestsFailed e -> Just e + BenchFailed e -> Just e InstallFailed e -> Just e DependentFailed _ -> Nothing @@ -987,4 +1116,3 @@ ++ "https://github.com/haskell/cabal/issues and if you\nhave any time " ++ "to get involved and help with testing, fixing bugs etc then\nthat " ++ "is very much appreciated.\n" - diff --git a/Distribution/Client/ProjectPlanOutput.hs b/Distribution/Client/ProjectPlanOutput.hs --- a/Distribution/Client/ProjectPlanOutput.hs +++ b/Distribution/Client/ProjectPlanOutput.hs @@ -10,7 +10,9 @@ -- | Several outputs rely on having a general overview of PostBuildProjectStatus(..), updatePostBuildProjectStatus, + createPackageEnvironment, writePlanGhcEnvironment, + argsEquivalentOfGhcEnvironmentFile, ) where import Distribution.Client.ProjectPlanning.Types @@ -29,10 +31,11 @@ import Distribution.System import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.PackageDescription as PD -import Distribution.Compiler (CompilerFlavor(GHC)) +import Distribution.Compiler (CompilerFlavor(GHC, GHCJS)) import Distribution.Simple.Compiler ( PackageDBStack, PackageDB(..) - , compilerVersion, compilerFlavor, showCompilerId ) + , compilerVersion, compilerFlavor, showCompilerId + , compilerId, CompilerId(..), Compiler ) import Distribution.Simple.GHC ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles) , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile @@ -45,8 +48,9 @@ import Distribution.Verbosity import qualified Paths_cabal_install as Our (version) -import Data.Maybe (maybeToList, fromMaybe) -import Data.Monoid +import Prelude () +import Distribution.Client.Compat.Prelude + import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set @@ -56,6 +60,7 @@ import System.FilePath import System.IO +import Distribution.Simple.Program.GHC (packageDbArgsDb) ----------------------------------------------------------------------------- -- Writing plan.json files @@ -132,7 +137,7 @@ , "pkg-name" J..= (jdisplay . pkgName . packageId) elab , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab , "flags" J..= J.object [ PD.unFlagName fn J..= v - | (fn,v) <- elabFlagAssignment elab ] + | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) ] ++ [ "pkg-src-sha256" J..= J.String (showHashValue hash) @@ -655,15 +660,52 @@ writeFileAtomic (distProjectCacheFile "up-to-date") $ Binary.encode upToDate +-- | Prepare a package environment that includes all the library dependencies +-- for a plan. +-- +-- When running cabal new-exec, we want to set things up so that the compiler +-- can find all the right packages (and nothing else). This function is +-- intended to do that work. It takes a location where it can write files +-- temporarily, in case the compiler wants to learn this information via the +-- filesystem, and returns any environment variable overrides the compiler +-- needs. +createPackageEnvironment :: Verbosity + -> FilePath + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> PostBuildProjectStatus + -> IO [(String, Maybe String)] +createPackageEnvironment verbosity + path + elaboratedPlan + elaboratedShared + buildStatus + | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC + = do + envFileM <- writePlanGhcEnvironment + path + elaboratedPlan + elaboratedShared + buildStatus + case envFileM of + Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)] + Nothing -> do + warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail" + return [] + | otherwise + = do + warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" + return [] + -- Writing .ghc.environment files -- -writePlanGhcEnvironment :: DistDirLayout +writePlanGhcEnvironment :: FilePath -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> PostBuildProjectStatus - -> IO () -writePlanGhcEnvironment DistDirLayout{distProjectRootDirectory} + -> IO (Maybe FilePath) +writePlanGhcEnvironment path elaboratedInstallPlan ElaboratedSharedConfig { pkgConfigCompiler = compiler, @@ -673,26 +715,24 @@ | compilerFlavor compiler == GHC , supportsPkgEnvFiles (getImplInfo compiler) --TODO: check ghcjs compat - --TODO: This feature is temporarily disabled due to #4010 - , False - = writeGhcEnvironmentFile - distProjectRootDirectory + = fmap Just $ writeGhcEnvironmentFile + path platform (compilerVersion compiler) - (renderGhcEnviromentFile distProjectRootDirectory - elaboratedInstallPlan - postBuildStatus) + (renderGhcEnvironmentFile path + elaboratedInstallPlan + postBuildStatus) --TODO: [required eventually] support for writing user-wide package -- environments, e.g. like a global project, but we would not put the -- env file in the home dir, rather it lives under ~/.ghc/ -writePlanGhcEnvironment _ _ _ _ = return () +writePlanGhcEnvironment _ _ _ _ = return Nothing -renderGhcEnviromentFile :: FilePath - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [GhcEnvironmentFileEntry] -renderGhcEnviromentFile projectRootDir elaboratedInstallPlan - postBuildStatus = +renderGhcEnvironmentFile :: FilePath + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [GhcEnvironmentFileEntry] +renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan + postBuildStatus = headerComment : simpleGhcEnvironmentFile packageDBs unitIds where @@ -703,11 +743,46 @@ ++ "But you still need to use cabal repl $target to get the environment\n" ++ "of specific components (libs, exes, tests etc) because each one can\n" ++ "have its own source dirs, cpp flags etc.\n\n" - unitIds = selectGhcEnviromentFileLibraries postBuildStatus + unitIds = selectGhcEnvironmentFileLibraries postBuildStatus packageDBs = relativePackageDBPaths projectRootDir $ - selectGhcEnviromentFilePackageDbs elaboratedInstallPlan + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan +argsEquivalentOfGhcEnvironmentFile + :: Compiler + -> DistDirLayout + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [String] +argsEquivalentOfGhcEnvironmentFile compiler = + case compilerId compiler + of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc + CompilerId _ _ -> error "Only GHC and GHCJS are supported" + +-- TODO remove this when we drop support for non-.ghc.env ghc +argsEquivalentOfGhcEnvironmentFileGhc + :: DistDirLayout + -> ElaboratedInstallPlan + -> PostBuildProjectStatus + -> [String] +argsEquivalentOfGhcEnvironmentFileGhc + distDirLayout + elaboratedInstallPlan + postBuildStatus = + clearPackageDbStackFlag + ++ packageDbArgsDb packageDBs + ++ foldMap packageIdFlag packageIds + where + projectRootDir = distProjectRootDirectory distDirLayout + packageIds = selectGhcEnvironmentFileLibraries postBuildStatus + packageDBs = relativePackageDBPaths projectRootDir $ + selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan + -- TODO use proper flags? but packageDbArgsDb is private + clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"] + packageIdFlag uid = ["-package-id", display uid] + + -- We're producing an environment for users to use in ghci, so of course -- that means libraries only (can't put exes into the ghc package env!). -- The library environment should be /consistent/ with the environment @@ -740,10 +815,10 @@ -- to find the libs) then those exes still end up in our list so we have -- to filter them out at the end. -- -selectGhcEnviromentFileLibraries :: PostBuildProjectStatus -> [UnitId] -selectGhcEnviromentFileLibraries PostBuildProjectStatus{..} = +selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId] +selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of - Nothing -> error "renderGhcEnviromentFile: broken dep closure" + Nothing -> error "renderGhcEnvironmentFile: broken dep closure" Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes , hasUpToDateLib pkg ] where @@ -761,8 +836,8 @@ && installedUnitId pkg `Set.member` packagesProbablyUpToDate -selectGhcEnviromentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack -selectGhcEnviromentFilePackageDbs elaboratedInstallPlan = +selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack +selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = -- If we have any inplace packages then their package db stack is the -- one we should use since it'll include the store + the local db but -- it's certainly possible to have no local inplace packages @@ -775,7 +850,7 @@ case ordNub (map elabBuildPackageDBStack pkgs) of [packageDbs] -> packageDbs [] -> [] - _ -> error $ "renderGhcEnviromentFile: packages with " + _ -> error $ "renderGhcEnvironmentFile: packages with " ++ "different package db stacks" -- This should not happen at the moment but will happen as soon -- as we support projects where we build packages with different diff --git a/Distribution/Client/ProjectPlanning.hs b/Distribution/Client/ProjectPlanning.hs --- a/Distribution/Client/ProjectPlanning.hs +++ b/Distribution/Client/ProjectPlanning.hs @@ -51,11 +51,17 @@ setupHsReplArgs, setupHsTestFlags, setupHsTestArgs, + setupHsBenchFlags, + setupHsBenchArgs, setupHsCopyFlags, setupHsRegisterFlags, setupHsHaddockFlags, packageHashInputs, + + -- * Path construction + binDirectoryFor, + binDirectories ) where import Prelude () @@ -74,6 +80,7 @@ import Distribution.Client.Dependency import Distribution.Client.Dependency.Types import qualified Distribution.Client.IndexUtils as IndexUtils +import Distribution.Client.Init (incVersion) import Distribution.Client.Targets (userToPackageConstraint) import Distribution.Client.DistDirLayout import Distribution.Client.SetupWrapper @@ -287,7 +294,8 @@ rebuildProjectConfig :: Verbosity -> DistDirLayout -> ProjectConfig - -> IO (ProjectConfig, [UnresolvedSourcePackage]) + -> IO (ProjectConfig, + [PackageSpecifier UnresolvedSourcePackage]) rebuildProjectConfig verbosity distDirLayout@DistDirLayout { distProjectRootDirectory, @@ -308,6 +316,10 @@ return (projectConfig <> cliConfig, localPackages) where + ProjectConfigShared { + projectConfigConfigFile + } = projectConfigShared cliConfig + fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config") -- Read the cabal.project (or implicit config) and combine it with @@ -317,17 +329,22 @@ phaseReadProjectConfig = do liftIO $ do info verbosity "Project settings changed, reconfiguring..." - createDirectoryIfMissingVerbose verbosity True distDirectory - createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - - readProjectConfig verbosity distDirLayout + readProjectConfig verbosity projectConfigConfigFile distDirLayout -- Look for all the cabal packages in the project -- some of which may be local src dirs, tarballs etc -- - phaseReadLocalPackages :: ProjectConfig -> Rebuild [UnresolvedSourcePackage] + phaseReadLocalPackages :: ProjectConfig + -> Rebuild [PackageSpecifier UnresolvedSourcePackage] phaseReadLocalPackages projectConfig = do localCabalFiles <- findProjectPackages distDirLayout projectConfig + + -- Create folder only if findProjectPackages did not throw a + -- BadPackageLocations exception. + liftIO $ do + createDirectoryIfMissingVerbose verbosity True distDirectory + createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + mapM (readSourcePackage verbosity) localCabalFiles @@ -347,7 +364,7 @@ rebuildInstallPlan :: Verbosity -> DistDirLayout -> CabalDirLayout -> ProjectConfig - -> [UnresolvedSourcePackage] + -> [PackageSpecifier UnresolvedSourcePackage] -> IO ( ElaboratedInstallPlan -- with store packages , ElaboratedInstallPlan -- with source packages , ElaboratedSharedConfig ) @@ -499,7 +516,7 @@ -- phaseRunSolver :: ProjectConfig -> (Compiler, Platform, ProgramDb) - -> [UnresolvedSourcePackage] + -> [PackageSpecifier UnresolvedSourcePackage] -> Rebuild (SolverInstallPlan, PkgConfigDb) phaseRunSolver projectConfig@ProjectConfig { projectConfigShared, @@ -547,7 +564,7 @@ Map.fromList [ (pkgname, stanzas) | pkg <- localPackages - , let pkgname = packageName pkg + , let pkgname = pkgSpecifierTarget pkg testsEnabled = lookupLocalPackageConfig packageConfigTests projectConfig pkgname @@ -569,11 +586,12 @@ -> (Compiler, Platform, ProgramDb) -> PkgConfigDb -> SolverInstallPlan - -> [SourcePackage loc] + -> [PackageSpecifier (SourcePackage loc)] -> Rebuild ( ElaboratedInstallPlan , ElaboratedSharedConfig ) phaseElaboratePlan ProjectConfig { projectConfigShared, + projectConfigAllPackages, projectConfigLocalPackages, projectConfigSpecificPackage, projectConfigBuildOnly @@ -601,6 +619,7 @@ sourcePackageHashes defaultInstallDirs projectConfigShared + projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage) let instantiatedPlan = instantiateInstallPlan elaboratedPlan @@ -705,7 +724,7 @@ -} getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a) - -> IndexUtils.IndexState -> Rebuild SourcePackageDb + -> Maybe IndexUtils.IndexState -> Rebuild SourcePackageDb getSourcePackages verbosity withRepoCtx idxState = do (sourcePkgDb, repos) <- liftIO $ @@ -714,9 +733,9 @@ repoctx idxState return (sourcePkgDb, repoContextRepos repoctx) - monitorFiles . map monitorFile - . IndexUtils.getSourcePackagesMonitorFiles - $ repos + mapM_ needIfExists + . IndexUtils.getSourcePackagesMonitorFiles + $ repos return sourcePkgDb @@ -878,7 +897,7 @@ -> InstalledPackageIndex -> SourcePackageDb -> PkgConfigDb - -> [UnresolvedSourcePackage] + -> [PackageSpecifier UnresolvedSourcePackage] -> Map PackageName (Map OptionalStanza Bool) -> Progress String String SolverInstallPlan planPackages verbosity comp platform solver SolverSettings{..} @@ -898,8 +917,7 @@ setMaxBackjumps solverSettingMaxBackjumps - --TODO: [required eventually] should only be configurable for custom installs - -- . setIndependentGoals solverSettingIndependentGoals + . setIndependentGoals solverSettingIndependentGoals . setReorderGoals solverSettingReorderGoals @@ -932,18 +950,8 @@ . PD.packageDescription . packageDescription) - . addSetupCabalMinVersionConstraint (mkVersion [1,20]) - -- While we can talk to older Cabal versions (we need to be able to - -- do so for custom Setup scripts that require older Cabal lib - -- versions), we have problems talking to some older versions that - -- don't support certain features. - -- - -- For example, Cabal-1.16 and older do not know about build targets. - -- Even worse, 1.18 and older only supported the --constraint flag - -- with source package ids, not --dependency with installed package - -- ids. That is bad because we cannot reliably select the right - -- dependencies in the presence of multiple instances (i.e. the - -- store). See issue #3932. So we require Cabal 1.20 as a minimum. + . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint + . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint . addPreferences -- preferences from the config file or command line @@ -959,7 +967,7 @@ -- enable stanza preference where the user did not specify [ PackageStanzasPreference pkgname stanzas | pkg <- localPackages - , let pkgname = packageName pkg + , let pkgname = pkgSpecifierTarget pkg stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable stanzas = [ stanza | stanza <- [minBound..maxBound] , Map.lookup stanza stanzaM == Nothing ] @@ -973,7 +981,7 @@ (PackagePropertyStanzas stanzas)) ConstraintSourceConfigFlagOrTarget | pkg <- localPackages - , let pkgname = packageName pkg + , let pkgname = pkgSpecifierTarget pkg stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable stanzas = [ stanza | stanza <- [minBound..maxBound] , Map.lookup stanza stanzaM == Just True ] @@ -999,9 +1007,9 @@ (PackagePropertyFlags flags)) ConstraintSourceConfigFlagOrTarget | let flags = solverSettingFlagAssignment - , not (null flags) + , not (PD.nullFlagAssignment flags) , pkg <- localPackages - , let pkgname = packageName pkg ] + , let pkgname = pkgSpecifierTarget pkg ] $ stdResolverParams @@ -1010,9 +1018,73 @@ -- its own addDefaultSetupDependencies that is not appropriate for us. basicInstallPolicy installedPkgIndex sourcePkgDb - (map SpecificSourcePackage localPackages) + localPackages + -- While we can talk to older Cabal versions (we need to be able to + -- do so for custom Setup scripts that require older Cabal lib + -- versions), we have problems talking to some older versions that + -- don't support certain features. + -- + -- For example, Cabal-1.16 and older do not know about build targets. + -- Even worse, 1.18 and older only supported the --constraint flag + -- with source package ids, not --dependency with installed package + -- ids. That is bad because we cannot reliably select the right + -- dependencies in the presence of multiple instances (i.e. the + -- store). See issue #3932. So we require Cabal 1.20 as a minimum. + -- + -- Moreover, lib:Cabal generally only supports the interface of + -- current and past compilers; in fact recent lib:Cabal versions + -- will warn when they encounter a too new or unknown GHC compiler + -- version (c.f. #415). To avoid running into unsupported + -- configurations we encode the compatiblity matrix as lower + -- bounds on lib:Cabal here (effectively corresponding to the + -- respective major Cabal version bundled with the respective GHC + -- release). + -- + -- GHC 8.4 needs Cabal >= 2.2 + -- GHC 8.2 needs Cabal >= 2.0 + -- GHC 8.0 needs Cabal >= 1.24 + -- GHC 7.10 needs Cabal >= 1.22 + -- + -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is + -- the absolute lower bound) + -- + -- TODO: long-term, this compatibility matrix should be + -- stored as a field inside 'Distribution.Compiler.Compiler' + setupMinCabalVersionConstraint + | isGHC, compVer >= mkVersion [8,4,1] = mkVersion [2,2] + -- GHC 8.4.1-rc1 (GHC 8.4.0.20180224) still shipped with an + -- devel snapshot of Cabal-2.1.0.0; the rule below can be + -- dropped at some point + | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,1] + | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0] + | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24] + | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22] + | otherwise = mkVersion [1,20] + where + isGHC = compFlav `elem` [GHC,GHCJS] + compFlav = compilerFlavor comp + compVer = compilerVersion comp + -- As we can't predict the future, we also place a global upper + -- bound on the lib:Cabal version we know how to interact with: + -- + -- The upper bound is computed by incrementing the current major + -- version twice in order to allow for the current version, as + -- well as the next adjacent major version (one of which will not + -- be released, as only "even major" versions of Cabal are + -- released to Hackage or bundled with proper GHC releases). + -- + -- For instance, if the current version of cabal-install is an odd + -- development version, e.g. Cabal-2.1.0.0, then we impose an + -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a + -- stable/release even version, e.g. Cabal-2.2.1.0, the upper + -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility + -- when dealing with development snapshots of Cabal and cabal-install. + -- + setupMaxCabalVersionConstraint = + alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion + ------------------------------------------------------------------------------ -- * Install plan post-processing ------------------------------------------------------------------------------ @@ -1122,20 +1194,22 @@ -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan - -> [SourcePackage loc] + -> [PackageSpecifier (SourcePackage loc)] -> Map PackageId PackageSourceHash -> InstallDirs.InstallDirTemplates -> ProjectConfigShared -> PackageConfig + -> PackageConfig -> Map PackageName PackageConfig -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB - DistDirLayout{..} + distDirLayout@DistDirLayout{..} storeDirLayout@StoreDirLayout{storePackageDBStack} solverPlan localPackages sourcePackageHashes defaultInstallDirs sharedPackageConfig + allPackagesConfig localPackagesConfig perPackageConfig = do x <- elaboratedInstallPlan @@ -1191,7 +1265,7 @@ if null not_per_component_reasons then return comps else do checkPerPackageOk comps not_per_component_reasons - return [elaborateSolverToPackage mapDep spkg g $ + return [elaborateSolverToPackage spkg g $ comps ++ maybeToList setupComponent] Left cns -> dieProgress $ @@ -1200,19 +1274,24 @@ where -- You are eligible to per-component build if this list is empty why_not_per_component g - = cuz_custom ++ cuz_spec ++ cuz_length ++ cuz_flag + = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag ++ cuz_coverage where cuz reason = [text reason] - -- At this point in time, only non-Custom setup scripts + -- We have to disable per-component for now with + -- Configure-type scripts in order to prevent parallel + -- invocation of the same `./configure` script. + -- See https://github.com/haskell/cabal/issues/4548 + -- + -- Moreoever, at this point in time, only non-Custom setup scripts -- are supported. Implementing per-component builds with -- Custom would require us to create a new 'ElabSetup' -- type, and teach all of the code paths how to handle it. -- Once you've implemented this, swap it for the code below. - cuz_custom = + cuz_buildtype = case PD.buildType (elabPkgDescription elab0) of - Nothing -> cuz "build-type is not specified" - Just PD.Custom -> cuz "build-type is Custom" - Just _ -> [] + PD.Configure -> cuz "build-type is Configure" + PD.Custom -> cuz "build-type is Custom" + _ -> [] -- cabal-format versions prior to 1.8 have different build-depends semantics -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 -- see, https://github.com/haskell/cabal/issues/4121 @@ -1232,6 +1311,12 @@ | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = [] | otherwise = cuz "you passed --disable-per-component" + -- Enabling program coverage introduces odd runtime dependencies + -- between components. + cuz_coverage + | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) + = cuz "program coverage is enabled" + | otherwise = [] -- | Sometimes a package may make use of features which are only -- supported in per-package mode. If this is the case, we should @@ -1246,7 +1331,7 @@ fsep (punctuate comma reasons) -- TODO: Maybe exclude Backpack too - elab0 = elaborateSolverToCommon mapDep spkg + elab0 = elaborateSolverToCommon spkg pkgid = elabPkgSourceId elab0 pd = elabPkgDescription elab0 @@ -1256,7 +1341,7 @@ -- have to add dependencies on this from all other components setupComponent :: Maybe ElaboratedConfiguredPackage setupComponent - | fromMaybe PD.Custom (PD.buildType (elabPkgDescription elab0)) == PD.Custom + | PD.buildType (elabPkgDescription elab0) == PD.Custom = Just elab0 { elabModuleShape = emptyModuleShape, elabUnitId = notImpl "elabUnitId", @@ -1435,22 +1520,16 @@ (compilerId compiler) cid - -- NB: For inplace NOT InstallPaths.bindir installDirs; for an - -- inplace build those values are utter nonsense. So we - -- have to guess where the directory is going to be. - -- Fortunately this is "stable" part of Cabal API. - -- But the way we get the build directory is A HORRIBLE - -- HACK. - inplace_bin_dir elab - | shouldBuildInplaceOnly spkg - = distBuildDirectory - (elabDistDirParams elaboratedSharedConfig elab) - "build" case Cabal.componentNameString cname of - Just n -> display n - Nothing -> "" - | otherwise - = InstallDirs.bindir (elabInstallDirs elab) + inplace_bin_dir elab = + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab $ + case Cabal.componentNameString cname of + Just n -> display n + Nothing -> "" + -- | Given a 'SolverId' referencing a dependency on a library, return -- the 'ElaboratedPlanPackage' corresponding to the library. This -- returns at most one result. @@ -1464,28 +1543,24 @@ planPackageExePath = -- Pre-existing executables are assumed to be in PATH -- already. In fact, this should be impossible. - -- Modest duplication with 'inplace_bin_dir' InstallPlan.foldPlanPackage (const Nothing) $ \elab -> Just $ - if elabBuildStyle elab == BuildInplaceOnly - then distBuildDirectory - (elabDistDirParams elaboratedSharedConfig elab) - "build" - case elabPkgOrComp elab of - ElabPackage _ -> "" - ElabComponent comp -> - case fmap Cabal.componentNameString - (compComponentName comp) of - Just (Just n) -> display n - _ -> "" - else InstallDirs.bindir (elabInstallDirs elab) + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab $ + case elabPkgOrComp elab of + ElabPackage _ -> "" + ElabComponent comp -> + case fmap Cabal.componentNameString + (compComponentName comp) of + Just (Just n) -> display n + _ -> "" - elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverPackage UnresolvedPkgLoc + elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc -> ComponentsGraph -> [ElaboratedConfiguredPackage] -> ElaboratedConfiguredPackage elaborateSolverToPackage - mapDep pkg@(SolverPackage (SourcePackage pkgid _gdesc _srcloc _descOverride) _flags _stanzas _deps0 _exe_deps0) compGraph comps = @@ -1494,7 +1569,7 @@ -- of the other fields of the elaboratedPackage. elab where - elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg elab = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId, elabComponentId = pkgInstalledId, @@ -1557,8 +1632,14 @@ } <- comps ] - -- Filled in later - pkgStanzasEnabled = Set.empty + -- NB: This is not the final setting of 'pkgStanzasEnabled'. + -- See [Sticky enabled testsuites]; we may enable some extra + -- stanzas opportunistically when it is cheap to do so. + -- + -- However, we start off by enabling everything that was + -- requested, so that we can maintain an invariant that + -- pkgStanzasEnabled is a superset of elabStanzasRequested + pkgStanzasEnabled = Map.keysSet (Map.filter (id :: Bool -> Bool) elabStanzasRequested) install_dirs | shouldBuildInplaceOnly pkg @@ -1585,10 +1666,9 @@ (compilerId compiler) pkgInstalledId - elaborateSolverToCommon :: (SolverId -> [ElaboratedPlanPackage]) - -> SolverPackage UnresolvedPkgLoc + elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc -> ElaboratedConfiguredPackage - elaborateSolverToCommon mapDep + elaborateSolverToCommon pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) flags stanzas deps0 _exe_deps0) = elaboratedPackage @@ -1613,7 +1693,8 @@ [] gdesc in desc elabFlagAssignment = flags - elabFlagDefaults = [ (Cabal.flagName flag, Cabal.flagDefault flag) + elabFlagDefaults = PD.mkFlagAssignment + [ (Cabal.flagName flag, Cabal.flagDefault flag) | flag <- PD.genPackageFlags gdesc ] elabEnabledSpec = enableStanzas stanzas @@ -1644,8 +1725,10 @@ -- Check the comments of those functions for more details. elabBuildTargets = [] elabTestTargets = [] + elabBenchTargets = [] elabReplTarget = Nothing - elabBuildHaddocks = False + elabBuildHaddocks = + perPkgOptionFlag pkgid False packageConfigDocumentation elabPkgSourceLocation = srcloc elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes @@ -1656,10 +1739,9 @@ elabRegisterPackageDBStack = buildAndRegisterDbs elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription - -- Computing the deps here is a little awful - deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0 - elabSetupScriptCliVersion = packageSetupScriptSpecVersion - elabSetupScriptStyle elabPkgDescription deps + elabSetupScriptCliVersion = + packageSetupScriptSpecVersion + elabSetupScriptStyle elabPkgDescription libDepGraph deps0 elabSetupPackageDBStack = buildAndRegisterDbs buildAndRegisterDbs @@ -1670,6 +1752,7 @@ elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary + elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still @@ -1684,6 +1767,7 @@ elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs + elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo @@ -1717,12 +1801,13 @@ elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs + elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - elabHaddockHscolour = perPkgOptionFlag pkgid False packageConfigHaddockHscolour + elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents @@ -1747,14 +1832,17 @@ lookupPerPkgOption :: (Package pkg, Monoid m) => pkg -> (PackageConfig -> m) -> m - lookupPerPkgOption pkg f - -- the project config specifies values that apply to packages local to - -- but by default non-local packages get all default config values - -- the project, and can specify per-package values for any package, - | isLocalToProject pkg = local `mappend` perpkg - | otherwise = perpkg + lookupPerPkgOption pkg f = + -- This is where we merge the options from the project config that + -- apply to all packages, all project local packages, and to specific + -- named packages + global `mappend` local `mappend` perpkg where - local = f localPackagesConfig + global = f allPackagesConfig + local | isLocalToProject pkg + = f localPackagesConfig + | otherwise + = mempty perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) inplacePackageDbs = storePackageDbs @@ -1776,15 +1864,25 @@ $ map packageId $ SolverInstallPlan.reverseDependencyClosure solverPlan - [ PlannedId (packageId pkg) - | pkg <- localPackages ] + (map PlannedId (Set.toList pkgsLocalToProject)) isLocalToProject :: Package pkg => pkg -> Bool isLocalToProject pkg = Set.member (packageId pkg) pkgsLocalToProject pkgsLocalToProject :: Set PackageId - pkgsLocalToProject = Set.fromList [ packageId pkg | pkg <- localPackages ] + pkgsLocalToProject = + Set.fromList (catMaybes (map shouldBeLocal localPackages)) + --TODO: localPackages is a misnomer, it's all project packages + -- here is where we decide which ones will be local! + where + shouldBeLocal :: PackageSpecifier (SourcePackage loc) -> Maybe PackageId + shouldBeLocal NamedPackage{} = Nothing + shouldBeLocal (SpecificSourcePackage pkg) = Just (packageId pkg) + -- TODO: It's not actually obvious for all of the + -- 'ProjectPackageLocation's that they should all be local. We might + -- need to provide the user with a choice. + -- Also, review use of SourcePackage's loc vs ProjectPackageLocation pkgsUseSharedLibrary :: Set PackageId pkgsUseSharedLibrary = @@ -1925,6 +2023,35 @@ (Map.fromList [ (req, OpenModuleVar req) | req <- Set.toList (modShapeRequires shape)]) +-- | Get the bin\/ directories that a package's executables should reside in. +-- +-- The result may be empty if the package does not build any executables. +-- +-- The result may have several entries if this is an inplace build of a package +-- with multiple executables. +binDirectories + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> [FilePath] +binDirectories layout config package = case elabBuildStyle package of + -- quick sanity check: no sense returning a bin directory if we're not going + -- to put any executables in it, that will just clog up the PATH + _ | noExecutables -> [] + BuildAndInstall -> [installedBinDirectory package] + BuildInplaceOnly -> map (root) $ case elabPkgOrComp package of + ElabComponent comp -> case compSolverName comp of + CD.ComponentExe n -> [display n] + _ -> [] + ElabPackage _ -> map (display . PD.exeName) + . PD.executables + . elabPkgDescription + $ package + where + noExecutables = null . PD.executables . elabPkgDescription $ package + root = distBuildDirectory layout (elabDistDirParams config package) + "build" + -- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the -- dependency graph considers only dependencies on libraries which are -- NOT from setup dependencies. Used to compute the set @@ -2309,6 +2436,7 @@ pkgHasEphemeralBuildTargets elab = isJust (elabReplTarget elab) || (not . null) (elabTestTargets elab) + || (not . null) (elabBenchTargets elab) || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab , subtarget /= WholeComponent ] @@ -2334,6 +2462,7 @@ data TargetAction = TargetActionBuild | TargetActionRepl | TargetActionTest + | TargetActionBench | TargetActionHaddock -- | Given a set of per-package\/per-component targets, take the subset of the @@ -2341,6 +2470,10 @@ -- to specify which optional stanzas to enable, and which targets within each -- package to build. -- +-- NB: Pruning happens after improvement, which is important because we +-- will prune differently depending on what is already installed (to +-- implement "sticky" test suite enabling behavior). +-- pruneInstallPlanToTargets :: TargetAction -> Map UnitId [ComponentTarget] -> ElaboratedInstallPlan -> ElaboratedInstallPlan @@ -2401,6 +2534,7 @@ (Nothing, _) -> elab (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } + (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt } (Just _, TargetActionHaddock) -> elab { elabBuildHaddocks = True } (Just _, TargetActionRepl) -> @@ -2426,19 +2560,20 @@ roots = mapMaybe find_root pkgs' prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') - where elab' = pruneOptionalStanzas elab + where elab' = addOptionalStanzas elab find_root (InstallPlan.Configured (PrunedPackage elab _)) = if not (null (elabBuildTargets elab) && null (elabTestTargets elab) + && null (elabBenchTargets elab) && isNothing (elabReplTarget elab) && not (elabBuildHaddocks elab)) then Just (installedUnitId elab) else Nothing find_root _ = Nothing - -- Decide whether or not to enable testsuites and benchmarks - -- + -- Note [Sticky enabled testsuites] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- The testsuite and benchmark targets are somewhat special in that we need -- to configure the packages with them enabled, and we need to do that even -- if we only want to build one of several testsuites. @@ -2452,18 +2587,31 @@ -- would involve unnecessarily reconfiguring the package with testsuites -- disabled. Technically this introduces a little bit of stateful -- behaviour to make this "sticky", but it should be benign. - -- - pruneOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - pruneOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = + + -- Decide whether or not to enable testsuites and benchmarks. + -- See [Sticky enabled testsuites] + addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = elab { elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) } where stanzas :: Set OptionalStanza - stanzas = optionalStanzasRequiredByTargets elab - <> optionalStanzasRequestedByDefault elab + -- By default, we enabled all stanzas requested by the user, + -- as per elabStanzasRequested, done in + -- 'elaborateSolverToPackage' + stanzas = pkgStanzasEnabled pkg + -- optionalStanzasRequiredByTargets has to be done at + -- prune-time because it depends on 'elabTestTargets' + -- et al, which is done by 'setRootTargets' at the + -- beginning of pruning. + <> optionalStanzasRequiredByTargets elab + -- optionalStanzasWithDepsAvailable has to be done at + -- prune-time because it depends on what packages are + -- installed, which is not known until after improvement + -- (pruning is done after improvement) <> optionalStanzasWithDepsAvailable availablePkgs elab pkg - pruneOptionalStanzas elab = elab + addOptionalStanzas elab = elab -- Calculate package dependencies but cut out those needed only by -- optional stanzas that we've determined we will not enable. @@ -2489,17 +2637,11 @@ [ stanza | ComponentTarget cname _ <- elabBuildTargets pkg ++ elabTestTargets pkg + ++ elabBenchTargets pkg ++ maybeToList (elabReplTarget pkg) , stanza <- maybeToList (componentOptionalStanza cname) ] - optionalStanzasRequestedByDefault :: ElaboratedConfiguredPackage - -> Set OptionalStanza - optionalStanzasRequestedByDefault = - Map.keysSet - . Map.filter (id :: Bool -> Bool) - . elabStanzasRequested - availablePkgs = Set.fromList [ installedUnitId pkg @@ -2668,7 +2810,7 @@ Left $ CannotPruneDependencies [ (pkg, missingDeps) | (pkg, missingDepIds) <- brokenPackages - , let missingDeps = catMaybes (map lookupDep missingDepIds) + , let missingDeps = mapMaybe lookupDep missingDepIds ] where -- lookup in the original unpruned graph @@ -2739,7 +2881,7 @@ | otherwise = SetupNonCustomInternalLib where - buildType = fromMaybe PD.Custom (PD.buildType pkg) + buildType = PD.buildType pkg -- | Part of our Setup.hs handling policy is implemented by getting the solver @@ -2819,31 +2961,34 @@ -- of what the solver picked for us, based on the explicit setup deps or the -- ones added implicitly by 'defaultSetupDeps'. -- -packageSetupScriptSpecVersion :: Package pkg - => SetupScriptStyle +packageSetupScriptSpecVersion :: SetupScriptStyle -> PD.PackageDescription - -> ComponentDeps [pkg] + -> Graph.Graph NonSetupLibDepSolverPlanPackage + -> ComponentDeps [SolverId] -> Version -- We're going to be using the internal Cabal library, so the spec version of -- that is simply the version of the Cabal library that cabal-install has been -- built with. -packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ = +packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ = cabalVersion -- If we happen to be building the Cabal lib itself then because that -- bootstraps itself then we use the version of the lib we're building. -packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ +packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _ | packageName pkg == cabalPkgname = packageVersion pkg -- In all other cases we have a look at what version of the Cabal lib the -- solver picked. Or if it didn't depend on Cabal at all (which is very rare) -- then we look at the .cabal file to see what spec version it declares. -packageSetupScriptSpecVersion _ pkg deps = - case find ((cabalPkgname ==) . packageName) (CD.setupDeps deps) of +packageSetupScriptSpecVersion _ pkg libDepGraph deps = + case find ((cabalPkgname ==) . packageName) setupLibDeps of Just dep -> packageVersion dep Nothing -> PD.specVersion pkg + where + setupLibDeps = map packageId $ fromMaybe [] $ + Graph.closure libDepGraph (CD.setupDeps deps) cabalPkgname, basePkgname :: PackageName @@ -2875,6 +3020,7 @@ -- in the store and local dbs. setupHsScriptOptions :: ElaboratedReadyPackage + -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> FilePath -> FilePath @@ -2884,7 +3030,7 @@ -- TODO: Fix this so custom is a separate component. Custom can ALWAYS -- be a separate component!!! setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - ElaboratedSharedConfig{..} srcdir builddir + plan ElaboratedSharedConfig{..} srcdir builddir isParallelBuild cacheLock = SetupScriptOptions { useCabalVersion = thisVersion elabSetupScriptCliVersion, @@ -2903,6 +3049,7 @@ useLoggingHandle = Nothing, -- this gets set later useWorkingDir = Just srcdir, useExtraPathEnv = elabExeDependencyPaths elab, + useExtraEnvOverrides = dataDirsEnvironmentForPlan plan, useWin32CleanHack = False, --TODO: [required eventually] forceExternalSetupMethod = isParallelBuild, setupCacheLock = Just cacheLock, @@ -2926,15 +3073,22 @@ -> CompilerId -> InstalledPackageId -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs StoreDirLayout{storePackageDirectory} +storePackageInstallDirs StoreDirLayout{ storePackageDirectory + , storeDirectory } compid ipkgid = InstallDirs.InstallDirs {..} where + store = storeDirectory compid prefix = storePackageDirectory compid (newSimpleUnitId ipkgid) bindir = prefix "bin" libdir = prefix "lib" libsubdir = "" - dynlibdir = libdir + -- Note: on macOS, we place libraries into + -- @store/lib@ to work around the load + -- command size limit of macOSs mach-o linker. + -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ + dynlibdir | buildOS == OSX = store "lib" + | otherwise = libdir flibdir = libdir libexecdir = prefix "libexec" libexecsubdir= "" @@ -2980,7 +3134,25 @@ ElabComponent _ -> toFlag elabComponentId configProgramPaths = Map.toList elabProgramPaths - configProgramArgs = Map.toList elabProgramArgs + configProgramArgs + | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True + -- workaround for + -- + -- It turns out, that even with Cabal 2.0, there's still cases such as e.g. + -- custom Setup.hs scripts calling out to GHC even when going via + -- @runProgram ghcProgram@, as e.g. happy does in its + -- + -- (see also ) + -- + -- So for now, let's pass the rather harmless and idempotent + -- `-hide-all-packages` flag to all invocations (which has + -- the benefit that every GHC invocation starts with a + -- conistently well-defined clean slate) until we find a + -- better way. + = Map.toList $ + Map.insertWith (++) "ghc" ["-hide-all-packages"] + elabProgramArgs + | otherwise = Map.toList elabProgramArgs configProgramPathExtra = toNubList elabProgramPathExtra configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) configHcPath = mempty -- we use configProgramPaths instead @@ -2988,6 +3160,8 @@ configVanillaLib = toFlag elabVanillaLib configSharedLib = toFlag elabSharedLib + configStaticLib = toFlag elabStaticLib + configDynExe = toFlag elabDynExe configGHCiLib = toFlag elabGHCiLib configProfExe = mempty @@ -3003,12 +3177,11 @@ configLibCoverage = mempty configOptimization = toFlag elabOptimization + configSplitSections = toFlag elabSplitSections configSplitObjs = toFlag elabSplitObjs configStripExes = toFlag elabStripExes configStripLibs = toFlag elabStripLibs configDebugInfo = toFlag elabDebugInfo - configAllowOlder = mempty -- we use configExactConfiguration True - configAllowNewer = mempty -- we use configExactConfiguration True configConfigurationsFlags = elabFlagAssignment configConfigureArgs = elabConfigureScriptArgs @@ -3059,7 +3232,7 @@ configScratchDir = mempty -- never use configUserInstall = mempty -- don't rely on defaults configPrograms_ = mempty -- never use, shouldn't exist - + configUseResponseFiles = mempty setupHsConfigureArgs :: ElaboratedConfiguredPackage -> [String] @@ -3082,7 +3255,8 @@ buildVerbosity = toFlag verbosity, buildDistPref = toFlag builddir, buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), - buildArgs = mempty -- unused, passed via args not flags + buildArgs = mempty, -- unused, passed via args not flags + buildCabalFilePath= mempty } @@ -3117,6 +3291,23 @@ setupHsTestArgs elab = mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab) + +setupHsBenchFlags :: ElaboratedConfiguredPackage + -> ElaboratedSharedConfig + -> Verbosity + -> FilePath + -> Cabal.BenchmarkFlags +setupHsBenchFlags _ _ verbosity builddir = Cabal.BenchmarkFlags + { benchmarkDistPref = toFlag builddir + , benchmarkVerbosity = toFlag verbosity + , benchmarkOptions = mempty + } + +setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] +setupHsBenchArgs elab = + mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab) + + setupHsReplFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig -> Verbosity @@ -3149,7 +3340,8 @@ copyArgs = [], -- TODO: could use this to only copy what we enabled copyDest = toFlag (InstallDirs.CopyTo destdir), copyDistPref = toFlag builddir, - copyVerbosity = toFlag verbosity + copyVerbosity = toFlag verbosity, + copyCabalFilePath = mempty } setupHsRegisterFlags :: ElaboratedConfiguredPackage @@ -3170,7 +3362,8 @@ regPrintId = mempty, -- never use regDistPref = toFlag builddir, regArgs = [], - regVerbosity = toFlag verbosity + regVerbosity = toFlag verbosity, + regCabalFilePath = mempty } setupHsHaddockFlags :: ElaboratedConfiguredPackage @@ -3187,19 +3380,20 @@ haddockHoogle = toFlag elabHaddockHoogle, haddockHtml = toFlag elabHaddockHtml, haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation, - haddockForHackage = mempty, --TODO: new flag + haddockForHackage = toFlag elabHaddockForHackage, haddockForeignLibs = toFlag elabHaddockForeignLibs, haddockExecutables = toFlag elabHaddockExecutables, haddockTestSuites = toFlag elabHaddockTestSuites, haddockBenchmarks = toFlag elabHaddockBenchmarks, haddockInternal = toFlag elabHaddockInternal, haddockCss = maybe mempty toFlag elabHaddockCss, - haddockHscolour = toFlag elabHaddockHscolour, + haddockLinkedSource = toFlag elabHaddockLinkedSource, haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, haddockContents = maybe mempty toFlag elabHaddockContents, haddockDistPref = toFlag builddir, haddockKeepTempFiles = mempty, --TODO: from build settings - haddockVerbosity = toFlag verbosity + haddockVerbosity = toFlag verbosity, + haddockCabalFilePath = mempty } {- @@ -3323,6 +3517,7 @@ pkgHashProfExeDetail = elabProfExeDetail, pkgHashCoverage = elabCoverage, pkgHashOptimization = elabOptimization, + pkgHashSplitSections = elabSplitSections, pkgHashSplitObjs = elabSplitObjs, pkgHashStripLibs = elabStripLibs, pkgHashStripExes = elabStripExes, @@ -3354,3 +3549,39 @@ --TODO: decide what to do if we encounter broken installed packages, -- since overwriting is never safe. + + +-- Path construction +------ + +-- | The path to the directory that contains a specific executable. +-- NB: For inplace NOT InstallPaths.bindir installDirs; for an +-- inplace build those values are utter nonsense. So we +-- have to guess where the directory is going to be. +-- Fortunately this is "stable" part of Cabal API. +-- But the way we get the build directory is A HORRIBLE +-- HACK. +binDirectoryFor + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> FilePath + -> FilePath +binDirectoryFor layout config package exe = case elabBuildStyle package of + BuildAndInstall -> installedBinDirectory package + BuildInplaceOnly -> inplaceBinRoot layout config package exe + +-- package has been built and installed. +installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath +installedBinDirectory = InstallDirs.bindir . elabInstallDirs + +-- | The path to the @build@ directory for an inplace build. +inplaceBinRoot + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> FilePath +inplaceBinRoot layout config package + = distBuildDirectory layout (elabDistDirParams config package) + "build" + diff --git a/Distribution/Client/ProjectPlanning/Types.hs b/Distribution/Client/ProjectPlanning/Types.hs --- a/Distribution/Client/ProjectPlanning/Types.hs +++ b/Distribution/Client/ProjectPlanning/Types.hs @@ -23,6 +23,7 @@ elabPkgConfigDependencies, elabInplaceDependencyBuildCacheFiles, elabRequiresRegistration, + dataDirsEnvironmentForPlan, elabPlanPackageName, elabConfiguredName, @@ -42,6 +43,7 @@ ComponentTarget(..), showComponentTarget, showTestComponentTarget, + showBenchComponentTarget, SubComponentTarget(..), isTestComponentTarget, @@ -68,18 +70,21 @@ import Distribution.Verbosity import Distribution.Text import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.PackageDescription (PackageDescription(..)) import Distribution.Package hiding (InstalledPackageId, installedPackageId) import Distribution.System import qualified Distribution.PackageDescription as Cabal import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Compiler +import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import qualified Distribution.Simple.BuildTarget as Cabal import Distribution.Simple.Program.Db import Distribution.ModuleName (ModuleName) import Distribution.Simple.LocalBuildInfo (ComponentName(..)) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.InstallDirs (PathTemplate) +import Distribution.Simple.Setup (HaddockTarget) import Distribution.Version import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -89,6 +94,7 @@ import Distribution.Simple.Utils (ordNub) import Data.Map (Map) +import Data.Maybe (catMaybes) import Data.Set (Set) import qualified Data.ByteString.Lazy as LBS import Distribution.Compat.Binary @@ -96,7 +102,7 @@ import qualified Data.Monoid as Mon import Data.Typeable import Control.Monad - +import System.FilePath (()) -- | The combination of an elaborated install plan plus a @@ -229,6 +235,7 @@ -- TODO: make per-component variants of these flags elabVanillaLib :: Bool, elabSharedLib :: Bool, + elabStaticLib :: Bool, elabDynExe :: Bool, elabGHCiLib :: Bool, elabProfLib :: Bool, @@ -238,6 +245,7 @@ elabCoverage :: Bool, elabOptimization :: OptimisationLevel, elabSplitObjs :: Bool, + elabSplitSections :: Bool, elabStripLibs :: Bool, elabStripExes :: Bool, elabDebugInfo :: DebugInfoLevel, @@ -258,12 +266,13 @@ elabHaddockHtml :: Bool, elabHaddockHtmlLocation :: Maybe String, elabHaddockForeignLibs :: Bool, + elabHaddockForHackage :: HaddockTarget, elabHaddockExecutables :: Bool, elabHaddockTestSuites :: Bool, elabHaddockBenchmarks :: Bool, elabHaddockInternal :: Bool, elabHaddockCss :: Maybe FilePath, - elabHaddockHscolour :: Bool, + elabHaddockLinkedSource :: Bool, elabHaddockHscolourCss :: Maybe FilePath, elabHaddockContents :: Maybe PathTemplate, @@ -282,6 +291,7 @@ -- Build time related: elabBuildTargets :: [ComponentTarget], elabTestTargets :: [ComponentTarget], + elabBenchTargets :: [ComponentTarget], elabReplTarget :: Maybe ComponentTarget, elabBuildHaddocks :: Bool, @@ -331,6 +341,38 @@ is_lib (CSubLibName _) = True is_lib _ = False +-- | Construct the environment needed for the data files to work. +-- This consists of a separate @*_datadir@ variable for each +-- inplace package in the plan. +dataDirsEnvironmentForPlan :: ElaboratedInstallPlan + -> [(String, Maybe FilePath)] +dataDirsEnvironmentForPlan = catMaybes + . fmap (InstallPlan.foldPlanPackage + (const Nothing) + dataDirEnvVarForPackage) + . InstallPlan.toList + +-- | Construct an environment variable that points +-- the package's datadir to its correct location. +-- This might be: +-- * 'Just' the package's source directory plus the data subdirectory +-- for inplace packages. +-- * 'Nothing' for packages installed in the store (the path was +-- already included in the package at install/build time). +-- * The other cases are not handled yet. See below. +dataDirEnvVarForPackage :: ElaboratedConfiguredPackage + -> Maybe (String, Maybe FilePath) +dataDirEnvVarForPackage pkg = + case (elabBuildStyle pkg, elabPkgSourceLocation pkg) + of (BuildAndInstall, _) -> Nothing + (BuildInplaceOnly, LocalUnpackedPackage path) -> Just + (pkgPathEnvVar (elabPkgDescription pkg) "datadir", + Just $ path dataDir (elabPkgDescription pkg)) + -- TODO: handle the other cases for PackageLocation. + -- We will only need this when we add support for + -- remote/local tarballs. + (BuildInplaceOnly, _) -> Nothing + instance Package ElaboratedConfiguredPackage where packageId = elabPkgSourceId @@ -411,7 +453,8 @@ elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderLibDependencies elab = case elabPkgOrComp elab of - ElabPackage _ -> map (newSimpleUnitId . confInstId) (elabLibDependencies elab) + ElabPackage pkg -> map (newSimpleUnitId . confInstId) $ + ordNub $ CD.flatDeps (pkgLibDependencies pkg) ElabComponent comp -> compOrderLibDependencies comp -- | The library dependencies (i.e., the libraries we depend on, NOT @@ -655,6 +698,10 @@ isTestComponentTarget :: ComponentTarget -> Bool isTestComponentTarget (ComponentTarget (CTestName _) _) = True isTestComponentTarget _ = False + +showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String +showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ display n +showBenchComponentTarget _ _ = Nothing --------------------------- -- Setup.hs script policy diff --git a/Distribution/Client/Reconfigure.hs b/Distribution/Client/Reconfigure.hs --- a/Distribution/Client/Reconfigure.hs +++ b/Distribution/Client/Reconfigure.hs @@ -1,11 +1,9 @@ module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where -import Control.Monad ( unless, when ) -import Data.Maybe ( isJust ) -import Data.Monoid hiding ( (<>) ) -import System.Directory ( doesFileExist ) +import Distribution.Client.Compat.Prelude -import Distribution.Compat.Semigroup +import Data.Monoid ( Any(..) ) +import System.Directory ( doesFileExist ) import Distribution.Verbosity @@ -31,9 +29,9 @@ -- | @Check@ represents a function to check some condition on type @a@. The -- returned 'Any' is 'True' if any part of the condition failed. newtype Check a = Check { - runCheck :: Any -- ^ Did any previous check fail? - -> a -- ^ value returned by previous checks - -> IO (Any, a) -- ^ Did this check fail? What value is returned? + runCheck :: Any -- Did any previous check fail? + -> a -- value returned by previous checks + -> IO (Any, a) -- Did this check fail? What value is returned? } instance Semigroup (Check a) where diff --git a/Distribution/Client/Sandbox.hs b/Distribution/Client/Sandbox.hs --- a/Distribution/Client/Sandbox.hs +++ b/Distribution/Client/Sandbox.hs @@ -80,11 +80,7 @@ , tryFindAddSourcePackageDesc) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) -#else -import Distribution.PackageDescription.Parse ( readGenericPackageDescription ) -#endif import Distribution.Simple.Compiler ( Compiler(..), PackageDB(..) ) import Distribution.Simple.Configure ( configCompilerAuxEx , getPackageDBContents diff --git a/Distribution/Client/Sandbox/Index.hs b/Distribution/Client/Sandbox/Index.hs --- a/Distribution/Client/Sandbox/Index.hs +++ b/Distribution/Client/Sandbox/Index.hs @@ -39,11 +39,12 @@ import Distribution.Verbosity ( Verbosity ) import qualified Data.ByteString.Lazy as BS +import Control.DeepSeq ( NFData(rnf) ) import Control.Exception ( evaluate, throw, Exception ) import Control.Monad ( liftM, unless ) import Control.Monad.Writer.Lazy (WriterT(..), runWriterT, tell) import Data.List ( (\\), intersect, nub, find ) -import Data.Maybe ( catMaybes, fromMaybe ) +import Data.Maybe ( catMaybes ) import Data.Either (partitionEithers) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist, @@ -57,6 +58,9 @@ buildTreePath :: !FilePath } +instance NFData BuildTreeRef where + rnf (BuildTreeRef _ fp) = rnf fp + defaultIndexFileName :: FilePath defaultIndexFileName = "00-index.tar" @@ -224,7 +228,7 @@ then tell [pth] >> return False else return True - convertWith dict pth = fromMaybe pth $ fmap fst $ find ((==pth) . snd) dict + convertWith dict pth = maybe pth fst $ find ((==pth) . snd) dict -- | A build tree ref can become ignored if the user later adds a build tree ref -- with the same package ID. We display ignored build tree refs when the user diff --git a/Distribution/Client/Sandbox/PackageEnvironment.hs b/Distribution/Client/Sandbox/PackageEnvironment.hs --- a/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -60,7 +60,7 @@ , syntaxError, warning ) import Distribution.System ( Platform ) import Distribution.Verbosity ( Verbosity, normal ) -import Control.Monad ( foldM, liftM2, when, unless ) +import Control.Monad ( foldM, liftM2, unless ) import Data.List ( partition, sortBy ) import Data.Maybe ( isJust ) import Data.Ord ( comparing ) @@ -297,7 +297,7 @@ return mempty where processConfigParse path (ParseOk warns parseResult) = do - when (not $ null warns) $ warn verbosity $ + unless (null warns) $ warn verbosity $ unlines (map (showPWarning path) warns) return parseResult processConfigParse path (ParseFailed err) = do @@ -322,7 +322,7 @@ Nothing -> die' verbosity $ "The package environment file '" ++ path ++ "' doesn't exist" Just (ParseOk warns parseResult) -> do - when (not $ null warns) $ warn verbosity $ + unless (null warns) $ warn verbosity $ unlines (map (showPWarning path) warns) return parseResult Just (ParseFailed err) -> do diff --git a/Distribution/Client/Security/DNS.hs b/Distribution/Client/Security/DNS.hs --- a/Distribution/Client/Security/DNS.hs +++ b/Distribution/Client/Security/DNS.hs @@ -1,17 +1,23 @@ +{-# LANGUAGE CPP #-} + module Distribution.Client.Security.DNS ( queryBootstrapMirrors ) where import Prelude () import Distribution.Client.Compat.Prelude - +import Network.URI (URI(..), URIAuth(..), parseURI) +import Distribution.Verbosity import Control.Monad import Control.DeepSeq (force) import Control.Exception (SomeException, evaluate, try) -import Network.URI (URI(..), URIAuth(..), parseURI) - import Distribution.Simple.Utils -import Distribution.Verbosity +import Distribution.Compat.Exception (displayException) + +#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) +import Network.DNS (queryTXT, Name(..), CharStr(..)) +import qualified Data.ByteString.Char8 as BS.Char8 +#else import Distribution.Simple.Program.Db ( emptyProgramDb, addKnownProgram , configureAllKnownPrograms, lookupProgram ) @@ -19,7 +25,7 @@ ( simpleProgram , programInvocation , getProgramInvocationOutput ) -import Distribution.Compat.Exception (displayException) +#endif -- | Try to lookup RFC1464-encoded mirror urls for a Hackage -- repository url by performing a DNS TXT lookup on the @@ -42,8 +48,48 @@ -- constitute a significant new attack vector anyway. -- queryBootstrapMirrors :: Verbosity -> URI -> IO [URI] + +#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns) +-- use @resolv@ package for performing DNS queries queryBootstrapMirrors verbosity repoUri | Just auth <- uriAuthority repoUri = do + let mirrorsDnsName = Name (BS.Char8.pack ("_mirrors." ++ uriRegName auth)) + + mirrors' <- try $ do + txts <- queryTXT mirrorsDnsName + evaluate (force $ extractMirrors (map snd txts)) + + mirrors <- case mirrors' of + Left e -> do + warn verbosity ("Caught exception during _mirrors lookup:"++ + displayException (e :: SomeException)) + return [] + Right v -> return v + + if null mirrors + then warn verbosity ("No mirrors found for " ++ show repoUri) + else do info verbosity ("located " ++ show (length mirrors) ++ + " mirrors for " ++ show repoUri ++ " :") + forM_ mirrors $ \url -> info verbosity ("- " ++ show url) + + return mirrors + + | otherwise = return [] + +-- | Extract list of mirrors from 'queryTXT' result +extractMirrors :: [[CharStr]] -> [URI] +extractMirrors txtChunks = mapMaybe (parseURI . snd) . sort $ vals + where + vals = [ (kn,v) | CharStr e <- concat txtChunks + , Just (k,v) <- [splitRfc1464 (BS.Char8.unpack e)] + , Just kn <- [isUrlBase k] + ] + +---------------------------------------------------------------------------- +#else /* !defined(MIN_VERSION_resolv) */ +-- use external method via @nslookup@ +queryBootstrapMirrors verbosity repoUri + | Just auth <- uriAuthority repoUri = do progdb <- configureAllKnownPrograms verbosity $ addKnownProgram nslookupProg emptyProgramDb @@ -90,13 +136,6 @@ , Just kn <- [isUrlBase k] ] - isUrlBase :: String -> Maybe Int - isUrlBase s - | isSuffixOf ".urlbase" s, not (null ns), all isDigit ns = readMaybe ns - | otherwise = Nothing - where - ns = take (length s - 8) s - -- | Parse output of @nslookup -query=TXT $HOSTNAME@ tolerantly parseNsLookupTxt :: String -> Maybe [(String,[String])] parseNsLookupTxt = go0 [] [] @@ -127,6 +166,17 @@ qstr acc ('"':cs) = Just (reverse acc, cs) qstr acc (c:cs) = qstr (c:acc) cs qstr _ [] = Nothing + +#endif +---------------------------------------------------------------------------- + +-- | Helper used by 'extractMirrors' for extracting @urlbase@ keys from Rfc1464-encoded data +isUrlBase :: String -> Maybe Int +isUrlBase s + | ".urlbase" `isSuffixOf` s, not (null ns), all isDigit ns = readMaybe ns + | otherwise = Nothing + where + ns = take (length s - 8) s -- | Split a TXT string into key and value according to RFC1464. -- Returns 'Nothing' if parsing fails. diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -26,7 +26,7 @@ , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , defaultSolver, defaultMaxBackjumps , listCommand, ListFlags(..) - , updateCommand + , updateCommand, UpdateFlags(..), defaultUpdateFlags , upgradeCommand , uninstallCommand , infoCommand, InfoFlags(..) @@ -45,11 +45,10 @@ , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) , actAsSetupCommand, ActAsSetupFlags(..) , sandboxCommand, defaultSandboxLocation, SandboxFlags(..) - , execCommand, ExecFlags(..) + , execCommand, ExecFlags(..), defaultExecFlags , userConfigCommand, UserConfigFlags(..) , manpageCommand - , applyFlagDefaults , parsePackageArgs --TODO: stop exporting these: , showRepo @@ -61,13 +60,15 @@ import Distribution.Client.Compat.Prelude hiding (get) import Distribution.Client.Types - ( Username(..), Password(..), RemoteRepo(..) ) + ( Username(..), Password(..), RemoteRepo(..) + , AllowNewer(..), AllowOlder(..), RelaxDeps(..) + ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Dependency.Types ( PreSolver(..) ) import Distribution.Client.IndexUtils.Timestamp - ( IndexState ) + ( IndexState(..) ) import qualified Distribution.Client.Init.Types as IT ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets @@ -114,7 +115,7 @@ import Distribution.ParseUtils ( readPToMaybe ) import Distribution.Verbosity - ( Verbosity, lessVerbose, normal, verboseNoFlags ) + ( Verbosity, lessVerbose, normal, verboseNoFlags, verboseNoTimestamp ) import Distribution.Simple.Utils ( wrapText, wrapLine ) import Distribution.Client.GlobalFlags @@ -129,15 +130,6 @@ import Network.URI ( parseAbsoluteURI, uriToString ) -applyFlagDefaults :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) - -> (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -applyFlagDefaults (configFlags, configExFlags, installFlags, haddockFlags) = - ( commandDefaultFlags configureCommand <> configFlags - , defaultConfigExFlags <> configExFlags - , defaultInstallFlags <> installFlags - , Cabal.defaultHaddockFlags <> haddockFlags - ) - globalCommand :: [Command action] -> CommandUI GlobalFlags globalCommand commands = CommandUI { commandName = "", @@ -408,7 +400,7 @@ filterConfigureFlags flags cabalLibVersion -- NB: we expect the latest version to be the most common case, -- so test it first. - | cabalLibVersion >= mkVersion [1,25,0] = flags_latest + | cabalLibVersion >= mkVersion [2,1,0] = flags_latest -- The naming convention is that flags_version gives flags with -- all flags *introduced* in version eliminated. -- It is NOT the latest version of Cabal library that @@ -425,22 +417,27 @@ | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0 | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0 | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0 + | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0 | otherwise = flags_latest where flags_latest = flags { -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. - configConstraints = [], - -- Passing '--allow-{older,newer}' to Setup.hs is unnecessary, we use - -- '--exact-configuration' instead. - configAllowOlder = Just (Cabal.AllowOlder Cabal.RelaxDepsNone), - configAllowNewer = Just (Cabal.AllowNewer Cabal.RelaxDepsNone) + configConstraints = [] } - flags_1_25_0 = flags_latest { + flags_2_1_0 = flags_latest { + -- Cabal < 2.1 doesn't know about -v +timestamp modifier + configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest) + -- Cabal < 2.1 doesn't know about ---static + , configStaticLib = NoFlag + , configSplitSections = NoFlag + } + + flags_1_25_0 = flags_2_1_0 { -- Cabal < 1.25.0 doesn't know about --dynlibdir. configInstallDirs = configInstallDirs_1_25_0, -- Cabal < 1.25 doesn't have extended verbosity syntax - configVerbosity = fmap verboseNoFlags (configVerbosity flags_latest), + configVerbosity = fmap verboseNoFlags (configVerbosity flags_2_1_0), -- Cabal < 1.25 doesn't support --deterministic configDeterministic = mempty } @@ -521,7 +518,9 @@ configCabalVersion :: Flag Version, configExConstraints:: [(UserConstraint, ConstraintSource)], configPreferences :: [Dependency], - configSolver :: Flag PreSolver + configSolver :: Flag PreSolver, + configAllowNewer :: Maybe AllowNewer, + configAllowOlder :: Maybe AllowOlder } deriving (Eq, Generic) @@ -570,8 +569,35 @@ , optionSolver configSolver (\v flags -> flags { configSolver = v }) + , option [] ["allow-older"] + ("Ignore lower bounds in all dependencies or DEPS") + (fmap unAllowOlder . configAllowOlder) + (\v flags -> flags { configAllowOlder = fmap AllowOlder v}) + (optArg "DEPS" + (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) + (Just RelaxDepsAll) relaxDepsPrinter) + + , option [] ["allow-newer"] + ("Ignore upper bounds in all dependencies or DEPS") + (fmap unAllowNewer . configAllowNewer) + (\v flags -> flags { configAllowNewer = fmap AllowNewer v}) + (optArg "DEPS" + (readP_to_E ("Cannot parse the list of packages: " ++) relaxDepsParser) + (Just RelaxDepsAll) relaxDepsPrinter) + ] + +relaxDepsParser :: Parse.ReadP r (Maybe RelaxDeps) +relaxDepsParser = + (Just . RelaxDepsSome) `fmap` Parse.sepBy1 parse (Parse.char ',') + +relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String] +relaxDepsPrinter Nothing = [] +relaxDepsPrinter (Just RelaxDepsAll) = [Nothing] +relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs + + instance Monoid ConfigExFlags where mempty = gmempty mappend = (<>) @@ -729,6 +755,8 @@ fetchShadowPkgs :: Flag ShadowPkgs, fetchStrongFlags :: Flag StrongFlags, fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, + fetchTests :: Flag Bool, + fetchBenchmarks :: Flag Bool, fetchVerbosity :: Flag Verbosity } @@ -745,6 +773,8 @@ fetchShadowPkgs = Flag (ShadowPkgs False), fetchStrongFlags = Flag (StrongFlags False), fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), + fetchTests = toFlag False, + fetchBenchmarks = toFlag False, fetchVerbosity = toFlag normal } @@ -782,6 +812,16 @@ fetchDryRun (\v flags -> flags { fetchDryRun = v }) trueArg + , option "" ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + fetchTests (\v flags -> flags { fetchTests = v }) + (boolOpt [] []) + + , option "" ["benchmarks"] + "dependency checking and compilation for benchmarks listed in the package description file." + fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v }) + (boolOpt [] []) + ] ++ optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) : @@ -1014,10 +1054,23 @@ (Parse.sepBy1 parse (Parse.char ',')) -- ------------------------------------------------------------ --- * Other commands +-- * Update command -- ------------------------------------------------------------ -updateCommand :: CommandUI (Flag Verbosity) +data UpdateFlags + = UpdateFlags { + updateVerbosity :: Flag Verbosity, + updateIndexState :: Flag IndexState + } deriving Generic + +defaultUpdateFlags :: UpdateFlags +defaultUpdateFlags + = UpdateFlags { + updateVerbosity = toFlag normal, + updateIndexState = toFlag IndexStateHead + } + +updateCommand :: CommandUI UpdateFlags updateCommand = CommandUI { commandName = "update", commandSynopsis = "Updates list of known packages.", @@ -1028,10 +1081,27 @@ ,"remote-repo-cache" ,"local-repo"], commandUsage = usageFlags "update", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] + commandDefaultFlags = defaultUpdateFlags, + commandOptions = \_ -> [ + optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }), + option [] ["index-state"] + ("Update the source package index to its state as it existed at a previous time. " ++ + "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').") + updateIndexState (\v flags -> flags { updateIndexState = v }) + (reqArg "STATE" (readP_to_E (const $ "index-state must be a " ++ + "unix-timestamps (e.g. '@1474732068'), " ++ + "a ISO8601 UTC timestamp " ++ + "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + ] } +-- ------------------------------------------------------------ +-- * Other commands +-- ------------------------------------------------------------ + upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) upgradeCommand = configureCommand { commandName = "upgrade", @@ -1406,6 +1476,7 @@ data InstallFlags = InstallFlags { installDocumentation :: Flag Bool, installHaddockIndex :: Flag PathTemplate, + installDest :: Flag Cabal.CopyDest, installDryRun :: Flag Bool, installMaxBackjumps :: Flag Int, installReorderGoals :: Flag ReorderGoals, @@ -1450,6 +1521,7 @@ defaultInstallFlags = InstallFlags { installDocumentation = Flag False, installHaddockIndex = Flag docIndexFile, + installDest = Flag Cabal.NoCopyDest, installDryRun = Flag False, installMaxBackjumps = Flag defaultMaxBackjumps, installReorderGoals = Flag (ReorderGoals False), @@ -1548,12 +1620,20 @@ commandDefaultFlags = (mempty, mempty, mempty, mempty), commandOptions = \showOrParseArgs -> liftOptions get1 set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", and + -- "exact-configuration" from the configure options. (filter ((`notElem` ["constraint", "dependency" , "exact-configuration"]) . optionName) $ configureOptions showOrParseArgs) ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) - ++ liftOptions get3 set3 (installOptions showOrParseArgs) + ++ liftOptions get3 set3 + -- hide "target-package-db" flag from the + -- install options. + (filter ((`notElem` ["target-package-db"]) + . optionName) $ + installOptions showOrParseArgs) ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) } where @@ -1572,7 +1652,7 @@ , name `elem` ["hoogle", "html", "html-location" ,"executables", "tests", "benchmarks", "all", "internal", "css" ,"hyperlink-source", "hscolour-css" - ,"contents-location"] + ,"contents-location", "for-hackage"] ] where fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a @@ -1598,6 +1678,12 @@ "Do not install anything, only print what would be installed." installDryRun (\v flags -> flags { installDryRun = v }) trueArg + + , option "" ["target-package-db"] + "package database to install into. Required when using ${pkgroot} prefix." + installDest (\v flags -> flags { installDest = v }) + (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb)) + (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> [])) ] ++ optionSolverFlags showOrParseArgs @@ -1946,6 +2032,12 @@ (\v flags -> flags { IT.packageType = v }) (noArg (Flag IT.Executable)) + , option [] ["is-libandexe"] + "Build a library and an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.LibraryAndExecutable)) + , option [] ["main-is"] "Specify the main module." IT.mainIs @@ -2317,14 +2409,16 @@ -- ------------------------------------------------------------ data UserConfigFlags = UserConfigFlags { - userConfigVerbosity :: Flag Verbosity, - userConfigForce :: Flag Bool -} deriving Generic + userConfigVerbosity :: Flag Verbosity, + userConfigForce :: Flag Bool, + userConfigAppendLines :: Flag [String] + } deriving Generic instance Monoid UserConfigFlags where mempty = UserConfigFlags { - userConfigVerbosity = toFlag normal, - userConfigForce = toFlag False + userConfigVerbosity = toFlag normal, + userConfigForce = toFlag False, + userConfigAppendLines = toFlag [] } mappend = (<>) @@ -2360,6 +2454,12 @@ "Overwrite the config file if it already exists." userConfigForce (\v flags -> flags { userConfigForce = v }) trueArg + , option ['a'] ["augment"] + "Additional setting to augment the config file (replacing a previous setting if it existed)." + userConfigAppendLines (\v flags -> flags + {userConfigAppendLines = + Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)}) + (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe)) ] } @@ -2399,7 +2499,7 @@ -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) -> [OptionField flags] -optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc _getig _setig +optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc getig setig getsip setsip getstrfl setstrfl getib setib = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") @@ -2416,14 +2516,11 @@ (fmap asBool . getcc) (setcc . fmap CountConflicts) (yesNoOpt showOrParseArgs) - -- TODO: Disabled for now because it may not be necessary -{- , option [] ["independent-goals"] "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." (fmap asBool . getig) (setig . fmap IndependentGoals) (yesNoOpt showOrParseArgs) --} , option [] ["shadow-installed-packages"] "If multiple package instances of the same version are installed, treat all but one as shadowed." (fmap asBool . getsip) diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -38,15 +38,10 @@ import Distribution.Types.Dependency import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) - , PackageDescription(..), specVersion - , BuildType(..), knownBuildTypes, defaultRenaming ) -#ifdef CABAL_PARSEC + , PackageDescription(..), specVersion, buildType + , BuildType(..), defaultRenaming ) import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) -#else -import Distribution.PackageDescription.Parse - ( readGenericPackageDescription ) -#endif import Distribution.Simple.Configure ( configCompilerEx ) import Distribution.Compiler @@ -91,7 +86,7 @@ , copyFileVerbose, rewriteFileEx ) import Distribution.Client.Utils ( inDir, tryCanonicalizePath, withExtraPathEnv - , existsAndIsMoreRecentThan, moreRecentFile, withEnv + , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides #ifdef mingw32_HOST_OS , canonicalizePathNoThrow #endif @@ -147,7 +142,7 @@ | ExternalMethod FilePath -- ^ run Cabal commands through a custom \"Setup\" executable ---TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two +-- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two -- parts: one that has no policy and just does as it's told with all the -- explicit options, and an optional initial part that applies certain -- policies (like if we should add the Cabal lib as a dep, and if so which @@ -190,6 +185,11 @@ useWorkingDir :: Maybe FilePath, -- | Extra things to add to PATH when invoking the setup script. useExtraPathEnv :: [FilePath], + -- | Extra environment variables paired with overrides, where + -- + -- * @'Just' v@ means \"set the environment variable's value to @v@\". + -- * 'Nothing' means \"unset the environment variable\". + useExtraEnvOverrides :: [(String, Maybe FilePath)], forceExternalSetupMethod :: Bool, -- | List of dependencies to use when building Setup.hs. @@ -264,6 +264,7 @@ useLoggingHandle = Nothing, useWorkingDir = Nothing, useExtraPathEnv = [], + useExtraEnvOverrides = [], useWin32CleanHack = False, forceExternalSetupMethod = False, setupCacheLock = Nothing, @@ -298,8 +299,7 @@ (useCabalVersion options) (orLaterVersion (specVersion pkg)) } - buildType' = fromMaybe Custom (buildType pkg) - checkBuildType buildType' + buildType' = buildType pkg (version, method, options'') <- getSetupMethod verbosity options' pkg buildType' return Setup { setupMethod = method @@ -313,12 +313,6 @@ >>= readGenericPackageDescription verbosity >>= return . packageDescription - checkBuildType (UnknownBuildType name) = - die' verbosity $ "The build-type '" ++ name ++ "' is not known. Use one of: " - ++ intercalate ", " (map display knownBuildTypes) ++ "." - checkBuildType _ = return () - - -- | Decide if we're going to be able to do a direct internal call to the -- entry point in the Cabal library or if we're going to have to compile -- and execute an external Setup.hs script. @@ -365,7 +359,7 @@ -- verbosity applies to ALL commands. verbosityHack :: Version -> [String] -> [String] verbosityHack ver args0 - | ver >= mkVersion [1,25] = args0 + | ver >= mkVersion [2,1] = args0 | otherwise = go args0 where go (('-':'v':rest) : args) @@ -380,11 +374,15 @@ munch rest = case runReadE flagToVerbosity rest of - Right v | verboseHasFlags v + Right v + | ver < mkVersion [2,0], verboseHasFlags v -- We could preserve the prefix, but since we're assuming -- it's Cabal's verbosity flag, we can assume that -- any format is OK -> Just (showForCabal (verboseNoFlags v)) + | ver < mkVersion [2,1], isVerboseTimestamp v + -- +timestamp wasn't yet available in Cabal-2.0.0 + -> Just (showForCabal (verboseNoTimestamp v)) _ -> Nothing -- | Run a command through a configured 'Setup'. @@ -422,7 +420,8 @@ inDir (useWorkingDir options) $ do withEnv "HASKELL_DIST_DIR" (useDistPref options) $ withExtraPathEnv (useExtraPathEnv options) $ - buildTypeAction bt args + withEnvOverrides (useExtraEnvOverrides options) $ + buildTypeAction bt args buildTypeAction :: BuildType -> ([String] -> IO ()) buildTypeAction Simple = Simple.defaultMainArgs @@ -430,7 +429,6 @@ Simple.autoconfUserHooks buildTypeAction Make = Make.defaultMainArgs buildTypeAction Custom = error "buildTypeAction Custom" -buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" -- | @runProcess'@ is a version of @runProcess@ where we have @@ -453,9 +451,7 @@ , Process.std_in = mbToStd mb_stdin , Process.std_out = mbToStd mb_stdout , Process.std_err = mbToStd mb_stderr -#if MIN_VERSION_process(1,2,0) , Process.delegate_ctlc = _delegate -#endif } return ph where @@ -483,8 +479,10 @@ searchpath <- programSearchPathAsPATHVar (map ProgramSearchPathDir (useExtraPathEnv options) ++ getProgramSearchPath (useProgramDb options)) - env <- getEffectiveEnvironment [("PATH", Just searchpath) - ,("HASKELL_DIST_DIR", Just (useDistPref options))] + env <- getEffectiveEnvironment $ + [ ("PATH", Just searchpath) + , ("HASKELL_DIST_DIR", Just (useDistPref options)) + ] ++ useExtraEnvOverrides options process <- runProcess' path args (useWorkingDir options) env Nothing (useLoggingHandle options) (useLoggingHandle options) @@ -516,9 +514,12 @@ searchpath <- programSearchPathAsPATHVar (map ProgramSearchPathDir (useExtraPathEnv options) ++ getProgramSearchPath (useProgramDb options)) - env <- getEffectiveEnvironment [("PATH", Just searchpath) - ,("HASKELL_DIST_DIR", Just (useDistPref options))] + env <- getEffectiveEnvironment $ + [ ("PATH", Just searchpath) + , ("HASKELL_DIST_DIR", Just (useDistPref options)) + ] ++ useExtraEnvOverrides options + debug verbosity $ "Setup arguments: "++unwords args process <- runProcess' path' args (useWorkingDir options) env Nothing (useLoggingHandle options) (useLoggingHandle options) @@ -702,8 +703,7 @@ then "autoconfUserHooks\n" else "defaultUserHooks\n" Make -> "import Distribution.Make; main = defaultMain\n" - Custom -> error "buildTypeScript Custom" - UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" + Custom -> error "buildTypeScript Custom" installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb -> IO (Version, Maybe InstalledPackageId @@ -788,8 +788,8 @@ buildTypeString = show bt cabalVersionString = "Cabal-" ++ (display cabalLibVersion) compilerVersionString = display $ - fromMaybe buildCompilerId - (fmap compilerId . useCompiler $ options') + maybe buildCompilerId compilerId + $ useCompiler options' platformString = display platform -- | Look up the setup executable in the cache; update the cache if the setup @@ -823,8 +823,7 @@ cachedSetupProgFile return cachedSetupProgFile where - criticalSection' = fromMaybe id - (fmap criticalSection $ setupCacheLock options') + criticalSection' = maybe id criticalSection $ setupCacheLock options' -- | If the Setup.hs is out of date wrt the executable then recompile it. -- Currently this is GHC/GHCJS only. It should really be generalised. diff --git a/Distribution/Client/SolverInstallPlan.hs b/Distribution/Client/SolverInstallPlan.hs --- a/Distribution/Client/SolverInstallPlan.hs +++ b/Distribution/Client/SolverInstallPlan.hs @@ -70,7 +70,7 @@ import Data.List ( intercalate ) import Data.Maybe - ( fromMaybe, catMaybes ) + ( fromMaybe, mapMaybe ) import Distribution.Compat.Binary (Binary(..)) import Distribution.Compat.Graph (Graph, IsNode(..)) import qualified Data.Graph as OldGraph @@ -226,10 +226,9 @@ problems indepGoals index = [ PackageMissingDeps pkg - (catMaybes - (map + (mapMaybe (fmap packageId . flip Graph.lookup index) - missingDeps)) + missingDeps) | (pkg, missingDeps) <- Graph.broken index ] ++ [ PackageCycle cycleGroup diff --git a/Distribution/Client/SourceRepoParse.hs b/Distribution/Client/SourceRepoParse.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/SourceRepoParse.hs @@ -0,0 +1,22 @@ +module Distribution.Client.SourceRepoParse where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.FieldGrammar.FieldDescrs (fieldDescrsToList) +import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar) +import Distribution.Parsec.Class (explicitEitherParsec) +import Distribution.ParseUtils (FieldDescr (..), syntaxError) +import Distribution.Types.SourceRepo (SourceRepo, RepoKind (..)) + +sourceRepoFieldDescrs :: [FieldDescr SourceRepo] +sourceRepoFieldDescrs = + map toDescr . fieldDescrsToList $ sourceRepoFieldGrammar (RepoKindUnknown "unused") + where + toDescr (name, pretty, parse) = FieldDescr + { fieldName = name + , fieldGet = pretty + , fieldSet = \lineNo str x -> + either (syntaxError lineNo) return + $ explicitEitherParsec (parse x) str + } diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs --- a/Distribution/Client/SrcDist.hs +++ b/Distribution/Client/SrcDist.hs @@ -20,13 +20,8 @@ ( PackageDescription ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) -#else -import Distribution.PackageDescription.Parse - ( readGenericPackageDescription ) -#endif import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, defaultPackageDesc , warn, die', notice, withTempDirectory ) diff --git a/Distribution/Client/Store.hs b/Distribution/Client/Store.hs --- a/Distribution/Client/Store.hs +++ b/Distribution/Client/Store.hs @@ -39,6 +39,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Control.Exception +import Control.Monad (forM_) import System.FilePath import System.Directory import System.IO @@ -171,7 +172,7 @@ -> StoreDirLayout -> CompilerId -> UnitId - -> (FilePath -> IO FilePath) -- ^ Action to place files. + -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files. -> IO () -- ^ Register action, if necessary. -> IO NewStoreEntryOutcome newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} @@ -182,7 +183,7 @@ withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do -- Write all store entry files within the temp dir and return the prefix. - incomingEntryDir <- copyFiles incomingTmpDir + (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir -- Take a lock named after the 'UnitId' in question. withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do @@ -207,6 +208,10 @@ -- Atomically rename the temp dir to the final store entry location. renameDirectory incomingEntryDir finalEntryDir + forM_ otherFiles $ \file -> do + let finalStoreFile = storeDirectory compid makeRelative (incomingTmpDir (dropDrive (storeDirectory compid))) file + createDirectoryIfMissing True (takeDirectory finalStoreFile) + renameFile file finalStoreFile debug verbosity $ "Installed store entry " ++ display compid display unitid diff --git a/Distribution/Client/TargetSelector.hs b/Distribution/Client/TargetSelector.hs --- a/Distribution/Client/TargetSelector.hs +++ b/Distribution/Client/TargetSelector.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, RecordWildCards #-} +{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, + RecordWildCards, NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.TargetSelector @@ -16,6 +17,7 @@ TargetSelector(..), TargetImplicitCwd(..), ComponentKind(..), + ComponentKindFilter, SubComponentTarget(..), QualLevel(..), componentKind, @@ -34,14 +36,16 @@ defaultDirActions, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Package - ( Package(..), PackageId, PackageIdentifier(..), packageName - , mkPackageName ) -import Distribution.Version - ( mkVersion ) -import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) + ( Package(..), PackageId, PackageName, packageName ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName + , packageNameToUnqualComponentName ) import Distribution.Client.Types - ( PackageLocation(..) ) + ( PackageLocation(..), PackageSpecifier(..) ) import Distribution.Verbosity import Distribution.PackageDescription @@ -62,7 +66,7 @@ import Distribution.Types.ForeignLib import Distribution.Text - ( display, simpleParse ) + ( Text, display, simpleParse ) import Distribution.Simple.Utils ( die', lowercase, ordNub ) import Distribution.Client.Utils @@ -73,36 +77,19 @@ import Data.Function ( on ) import Data.List - ( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy ) -import Data.Maybe - ( maybeToList ) + ( stripPrefix, partition, groupBy ) import Data.Ord ( comparing ) -import Distribution.Compat.Binary (Binary) -import GHC.Generics (Generic) -#if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Lazy as Map.Lazy import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -#else -import qualified Data.Map as Map.Lazy -import qualified Data.Map as Map -import Data.Map (Map) -#endif import qualified Data.Set as Set import Control.Arrow ((&&&)) import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..), (<$>)) -#endif -import Control.Applicative (Alternative(..)) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) import Distribution.ParseUtils ( readPToMaybe ) -import Data.Char - ( isSpace, isAlphaNum ) import System.FilePath as FilePath ( takeExtension, dropExtension , splitDirectories, joinPath, splitPath ) @@ -139,24 +126,42 @@ -- > [ [lib:|exe:] component name ] -- > [ module name | source file ] -- -data TargetSelector pkg = +data TargetSelector = - -- | A package as a whole: the default components for the package or all - -- components of a particular kind. + -- | One (or more) packages as a whole, or all the components of a + -- particular kind within the package(s). -- - TargetPackage TargetImplicitCwd pkg (Maybe ComponentKindFilter) + -- These are always packages that are local to the project. In the case + -- that there is more than one, they all share the same directory location. + -- + TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) + -- | A package specified by name. This may refer to @extra-packages@ from + -- the @cabal.project@ file, or a dependency of a known project package or + -- could refer to a package from a hackage archive. It needs further + -- context to resolve to a specific package. + -- + | TargetPackageNamed PackageName (Maybe ComponentKindFilter) + -- | All packages, or all components of a particular kind in all packages. -- | TargetAllPackages (Maybe ComponentKindFilter) - -- | A specific component in a package. + -- | A specific component in a package within the project. -- - | TargetComponent pkg ComponentName SubComponentTarget - deriving (Eq, Ord, Functor, Show, Generic) + | TargetComponent PackageId ComponentName SubComponentTarget + -- | A component in a package, but where it cannot be verified that the + -- package has such a component, or because the package is itself not + -- known. + -- + | TargetComponentUnknown PackageName + (Either UnqualComponentName ComponentName) + SubComponentTarget + deriving (Eq, Ord, Show, Generic) + -- | Does this 'TargetPackage' selector arise from syntax referring to a --- packge in the current directory (e.g. @tests@ or no giving no explicit +-- package in the current directory (e.g. @tests@ or no giving no explicit -- target at all) or does it come from syntax referring to a package name -- or location. -- @@ -195,40 +200,26 @@ -- error if any are unrecognised. The possible target selectors are based on -- the available packages (and their locations). -- -readTargetSelectors :: [SourcePackage (PackageLocation a)] +readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] -> [String] - -> IO (Either [TargetSelectorProblem] - [TargetSelector PackageId]) + -> IO (Either [TargetSelectorProblem] [TargetSelector]) readTargetSelectors = readTargetSelectorsWith defaultDirActions readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m - -> [SourcePackage (PackageLocation a)] + -> [PackageSpecifier (SourcePackage (PackageLocation a))] -> [String] - -> m (Either [TargetSelectorProblem] - [TargetSelector PackageId]) + -> m (Either [TargetSelectorProblem] [TargetSelector]) readTargetSelectorsWith dirActions@DirActions{..} pkgs targetStrs = case parseTargetStrings targetStrs of - ([], utargets) -> do - utargets' <- mapM (getTargetStringFileStatus dirActions) utargets - pkgs' <- mapM (selectPackageInfo dirActions) pkgs - cwd <- getCurrentDirectory - let (cwdPkg, otherPkgs) = selectCwdPackage cwd pkgs' - case resolveTargetSelectors cwdPkg otherPkgs utargets' of - ([], btargets) -> return (Right (map (fmap packageId) btargets)) + ([], usertargets) -> do + usertargets' <- mapM (getTargetStringFileStatus dirActions) usertargets + knowntargets <- getKnownTargets dirActions pkgs + case resolveTargetSelectors knowntargets usertargets' of + ([], btargets) -> return (Right btargets) (problems, _) -> return (Left problems) (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) - where - selectCwdPackage :: FilePath - -> [PackageInfo] - -> ([PackageInfo], [PackageInfo]) - selectCwdPackage cwd pkgs' = - let (cwdpkg, others) = partition isPkgDirCwd pkgs' - in (cwdpkg, others) - where - isPkgDirCwd PackageInfo { pinfoDirectory = Just (dir,_) } - | dir == cwd = True - isPkgDirCwd _ = False + data DirActions m = DirActions { doesFileExist :: FilePath -> m Bool, doesDirectoryExist :: FilePath -> m Bool, @@ -350,23 +341,29 @@ components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] -showTargetSelector :: Package p => TargetSelector p -> String +showTargetSelector :: TargetSelector -> String showTargetSelector ts = - let (t':_) = [ t | ql <- [QL1 .. QLFull] - , t <- renderTargetSelector ql ts ] - in showTargetString (forgetFileStatus t') + case [ t | ql <- [QL1 .. QLFull] + , t <- renderTargetSelector ql ts ] + of (t':_) -> showTargetString (forgetFileStatus t') + [] -> "" -showTargetSelectorKind :: TargetSelector a -> String +showTargetSelectorKind :: TargetSelector -> String showTargetSelectorKind bt = case bt of TargetPackage TargetExplicitNamed _ Nothing -> "package" TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" - TargetAllPackages Nothing -> "all-packages" - TargetAllPackages (Just _) -> "all-packages:filter" - TargetComponent _ _ WholeComponent -> "component" - TargetComponent _ _ ModuleTarget{} -> "module" - TargetComponent _ _ FileTarget{} -> "file" + TargetPackageNamed _ Nothing -> "named-package" + TargetPackageNamed _ (Just _) -> "named-package:filter" + TargetAllPackages Nothing -> "package *" + TargetAllPackages (Just _) -> "package *:filter" + TargetComponent _ _ WholeComponent -> "component" + TargetComponent _ _ ModuleTarget{} -> "module" + TargetComponent _ _ FileTarget{} -> "file" + TargetComponentUnknown _ _ WholeComponent -> "unknown-component" + TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module" + TargetComponentUnknown _ _ FileTarget{} -> "unknown-file" -- ------------------------------------------------------------ @@ -436,43 +433,38 @@ -- | Given a bunch of user-specified targets, try to resolve what it is they -- refer to. -- -resolveTargetSelectors :: [PackageInfo] -- any pkg in the cur dir - -> [PackageInfo] -- all the other local packages +resolveTargetSelectors :: KnownTargets -> [TargetStringFileStatus] -> ([TargetSelectorProblem], - [TargetSelector PackageInfo]) - + [TargetSelector]) -- default local dir target if there's no given target: -resolveTargetSelectors [] [] [] = +resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] = ([TargetSelectorNoTargetsInProject], []) -resolveTargetSelectors [] _opinfo [] = +resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] = ([TargetSelectorNoTargetsInCwd], []) -resolveTargetSelectors ppinfo _opinfo [] = - ([], [TargetPackage TargetImplicitCwd (head ppinfo) Nothing]) - --TODO: in future allow multiple packages in the same dir +resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] = + ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) + where + pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] -resolveTargetSelectors ppinfo opinfo targetStrs = +resolveTargetSelectors knowntargets targetStrs = partitionEithers - . map (resolveTargetSelector ppinfo opinfo) + . map (resolveTargetSelector knowntargets) $ targetStrs -resolveTargetSelector :: [PackageInfo] -> [PackageInfo] +resolveTargetSelector :: KnownTargets -> TargetStringFileStatus - -> Either TargetSelectorProblem - (TargetSelector PackageInfo) -resolveTargetSelector ppinfo opinfo targetStrStatus = + -> Either TargetSelectorProblem TargetSelector +resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus = case findMatch (matcher targetStrStatus) of Unambiguous _ | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - Unambiguous (TargetPackage TargetImplicitCwd _ mkfilter) - | null ppinfo -> Left (TargetSelectorNoCurrentPackage targetStr) - | otherwise -> Right (TargetPackage TargetImplicitCwd - (head ppinfo) mkfilter) - --TODO: in future allow multiple packages in the same dir + Unambiguous (TargetPackage TargetImplicitCwd [] _) + -> Left (TargetSelectorNoCurrentPackage targetStr) Unambiguous target -> Right target @@ -484,18 +476,15 @@ case disambiguateTargetSelectors matcher targetStrStatus exactMatch targets of - Right targets' -> Left (TargetSelectorAmbiguous targetStr - (map (fmap (fmap packageId)) targets')) - Left ((m, ms):_) -> Left (MatchingInternalError targetStr - (fmap packageId m) - (map (fmap (map (fmap packageId))) ms)) + Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') + Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms) Left [] -> internalError "resolveTargetSelector" where - matcher = matchTargetSelector ppinfo opinfo + matcher = matchTargetSelector knowntargets targetStr = forgetFileStatus targetStrStatus - projectIsEmpty = null ppinfo && null opinfo + projectIsEmpty = null knownPackagesAll classifyMatchErrors errs | not (null expected) @@ -552,10 +541,10 @@ [(Maybe (String, String), String, String, [String])] -- ^ [([in thing], no such thing, actually got, alternatives)] | TargetSelectorAmbiguous TargetString - [(TargetString, TargetSelector PackageId)] + [(TargetString, TargetSelector)] - | MatchingInternalError TargetString (TargetSelector PackageId) - [(TargetString, [TargetSelector PackageId])] + | MatchingInternalError TargetString TargetSelector + [(TargetString, [TargetSelector])] | TargetSelectorUnrecognised String -- ^ Syntax error when trying to parse a target string. | TargetSelectorNoCurrentPackage TargetString @@ -567,12 +556,11 @@ deriving (Eq, Enum, Show) disambiguateTargetSelectors - :: (TargetStringFileStatus -> Match (TargetSelector PackageInfo)) - -> TargetStringFileStatus -> Bool - -> [TargetSelector PackageInfo] - -> Either [(TargetSelector PackageInfo, - [(TargetString, [TargetSelector PackageInfo])])] - [(TargetString, TargetSelector PackageInfo)] + :: (TargetStringFileStatus -> Match TargetSelector) + -> TargetStringFileStatus -> MatchClass + -> [TargetSelector] + -> Either [(TargetSelector, [(TargetString, [TargetSelector])])] + [(TargetString, TargetSelector)] disambiguateTargetSelectors matcher matchInput exactMatch matchResults = case partitionEithers results of (errs@(_:_), _) -> Left errs @@ -581,8 +569,7 @@ -- So, here's the strategy. We take the original match results, and make a -- table of all their renderings at all qualification levels. -- Note there can be multiple renderings at each qualification level. - matchResultsRenderings :: [(TargetSelector PackageInfo, - [TargetStringFileStatus])] + matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])] matchResultsRenderings = [ (matchResult, matchRenderings) | matchResult <- matchResults @@ -597,12 +584,12 @@ -- for all of those renderings. So by looking up in this table we can see -- if we've got an unambiguous match. - memoisedMatches :: Map TargetStringFileStatus - (Match (TargetSelector PackageInfo)) + memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector) memoisedMatches = -- avoid recomputing the main one if it was an exact match - (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults) - else id) + (if exactMatch == Exact + then Map.insert matchInput (Match Exact 0 matchResults) + else id) $ Map.Lazy.fromList [ (rendering, matcher rendering) | rendering <- concatMap snd matchResultsRenderings ] @@ -611,9 +598,8 @@ -- possible renderings (in order of qualification level, though remember -- there can be multiple renderings per level), and find the first one -- that has an unambiguous match. - results :: [Either (TargetSelector PackageInfo, - [(TargetString, [TargetSelector PackageInfo])]) - (TargetString, TargetSelector PackageInfo)] + results :: [Either (TargetSelector, [(TargetString, [TargetSelector])]) + (TargetString, TargetSelector)] results = [ case findUnambiguous originalMatch matchRenderings of Just unambiguousRendering -> @@ -625,23 +611,24 @@ Left ( originalMatch , [ (forgetFileStatus rendering, matches) | rendering <- matchRenderings - , let (ExactMatch _ matches) = + , let (Match m _ matches) | m /= Inexact = memoisedMatches Map.! rendering ] ) | (originalMatch, matchRenderings) <- matchResultsRenderings ] - findUnambiguous :: TargetSelector PackageInfo + findUnambiguous :: TargetSelector -> [TargetStringFileStatus] -> Maybe TargetStringFileStatus findUnambiguous _ [] = Nothing findUnambiguous t (r:rs) = case memoisedMatches Map.! r of - ExactMatch _ [t'] | fmap packageName t == fmap packageName t' - -> Just r - ExactMatch _ _ -> findUnambiguous t rs - InexactMatch _ _ -> internalError "InexactMatch" - NoMatch _ _ -> internalError "NoMatch" + Match Exact _ [t'] | t == t' + -> Just r + Match Exact _ _ -> findUnambiguous t rs + Match Unknown _ _ -> findUnambiguous t rs + Match Inexact _ _ -> internalError "Match Inexact" + NoMatch _ _ -> internalError "NoMatch" internalError :: String -> a internalError msg = @@ -781,8 +768,8 @@ | AmbiguousAlternatives Syntax Syntax | ShadowingAlternatives Syntax Syntax -type Matcher = TargetStringFileStatus -> Match (TargetSelector PackageInfo) -type Renderer = TargetSelector PackageId -> [TargetStringFileStatus] +type Matcher = TargetStringFileStatus -> Match TargetSelector +type Renderer = TargetSelector -> [TargetStringFileStatus] foldSyntax :: (a -> a -> a) -> (a -> a -> a) -> (QualLevel -> Matcher -> Renderer -> a) @@ -798,29 +785,30 @@ -- Top level renderer and matcher -- -renderTargetSelector :: Package p => QualLevel -> TargetSelector p +renderTargetSelector :: QualLevel -> TargetSelector -> [TargetStringFileStatus] renderTargetSelector ql ts = foldSyntax (++) (++) - (\ql' _ render -> guard (ql == ql') >> render (fmap packageId ts)) + (\ql' _ render -> guard (ql == ql') >> render ts) syntax where - syntax = syntaxForms [] [] -- don't need pinfo for rendering + syntax = syntaxForms emptyKnownTargets + -- don't need known targets for rendering -matchTargetSelector :: [PackageInfo] -> [PackageInfo] +matchTargetSelector :: KnownTargets -> TargetStringFileStatus - -> Match (TargetSelector PackageInfo) -matchTargetSelector ppinfo opinfo = \utarget -> - nubMatchesBy ((==) `on` (fmap packageName)) $ + -> Match TargetSelector +matchTargetSelector knowntargets = \usertarget -> + nubMatchesBy (==) $ - let ql = targetQualLevel utarget in + let ql = targetQualLevel usertarget in foldSyntax (<|>) () - (\ql' match _ -> guard (ql == ql') >> match utarget) + (\ql' match _ -> guard (ql == ql') >> match usertarget) syntax where - syntax = syntaxForms ppinfo opinfo + syntax = syntaxForms knowntargets targetQualLevel TargetStringFileStatus1{} = QL1 targetQualLevel TargetStringFileStatus2{} = QL2 @@ -836,8 +824,14 @@ -- | All the forms of syntax for 'TargetSelector'. -- -syntaxForms :: [PackageInfo] -> [PackageInfo] -> Syntax -syntaxForms ppinfo opinfo = +syntaxForms :: KnownTargets -> Syntax +syntaxForms KnownTargets { + knownPackagesAll = pinfo, + knownPackagesPrimary = ppinfo, + knownComponentsAll = cinfo, + knownComponentsPrimary = pcinfo, + knownComponentsOther = ocinfo + } = -- The various forms of syntax here are ambiguous in many cases. -- Our policy is by default we expose that ambiguity and report -- ambiguous matches. In certain cases we override the ambiguity @@ -853,7 +847,7 @@ [ shadowingAlternatives [ ambiguousAlternatives [ syntaxForm1All - , syntaxForm1Filter + , syntaxForm1Filter ppinfo , shadowingAlternatives [ syntaxForm1Component pcinfo , syntaxForm1Package pinfo @@ -895,7 +889,7 @@ -- fully-qualified forms for all and cwd with filter , syntaxForm3MetaAllFilter - , syntaxForm3MetaCwdFilter + , syntaxForm3MetaCwdFilter ppinfo -- fully-qualified form for package and package with filter , syntaxForm3MetaNamespacePackage pinfo @@ -909,10 +903,6 @@ where ambiguousAlternatives = foldr1 AmbiguousAlternatives shadowingAlternatives = foldr1 ShadowingAlternatives - pinfo = ppinfo ++ opinfo - cinfo = concatMap pinfoComponents pinfo - pcinfo = concatMap pinfoComponents ppinfo - ocinfo = concatMap pinfoComponents opinfo -- | Syntax: "all" to select all packages in the project @@ -933,57 +923,50 @@ -- -- > cabal build tests -- -syntaxForm1Filter :: Syntax -syntaxForm1Filter = +syntaxForm1Filter :: [KnownPackage] -> Syntax +syntaxForm1Filter ps = syntaxForm1 render $ \str1 _fstatus1 -> do kfilter <- matchComponentKindFilter str1 - return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter)) + return (TargetPackage TargetImplicitCwd pids (Just kfilter)) where + pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus1 (dispF kfilter) noFileStatus] render _ = [] --- Only used for TargetPackage TargetImplicitCwd -dummyPackageInfo :: PackageInfo -dummyPackageInfo = - PackageInfo { - pinfoId = PackageIdentifier - (mkPackageName "dummyPackageInfo") - (mkVersion []), - pinfoLocation = unused, - pinfoDirectory = unused, - pinfoPackageFile = unused, - pinfoComponents = unused - } - where - unused = error "dummyPackageInfo" -- | Syntax: package (name, dir or file) -- -- > cabal build foo -- > cabal build ../bar ../bar/bar.cabal -- -syntaxForm1Package :: [PackageInfo] -> Syntax +syntaxForm1Package :: [KnownPackage] -> Syntax syntaxForm1Package pinfo = syntaxForm1 render $ \str1 fstatus1 -> do guardPackage str1 fstatus1 p <- matchPackage pinfo str1 fstatus1 - return (TargetPackage TargetExplicitNamed p Nothing) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) where - render (TargetPackage TargetExplicitNamed p Nothing) = + render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus1 (dispP p) noFileStatus] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus1 (dispPN pn) noFileStatus] render _ = [] -- | Syntax: component -- -- > cabal build foo -- -syntaxForm1Component :: [ComponentInfo] -> Syntax +syntaxForm1Component :: [KnownComponent] -> Syntax syntaxForm1Component cs = syntaxForm1 render $ \str1 _fstatus1 -> do guardComponentName str1 c <- matchComponentName cs str1 - return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent) + return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus1 (dispC p c) noFileStatus] @@ -993,13 +976,13 @@ -- -- > cabal build Data.Foo -- -syntaxForm1Module :: [ComponentInfo] -> Syntax +syntaxForm1Module :: [KnownComponent] -> Syntax syntaxForm1Module cs = syntaxForm1 render $ \str1 _fstatus1 -> do guardModuleName str1 let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] (m,c) <- matchModuleNameAnd ms str1 - return (TargetComponent (cinfoPackage c) (cinfoName c) (ModuleTarget m)) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) where render (TargetComponent _p _c (ModuleTarget m)) = [TargetStringFileStatus1 (dispM m) noFileStatus] @@ -1009,7 +992,7 @@ -- -- > cabal build Data/Foo.hs bar/Main.hsc -- -syntaxForm1File :: [PackageInfo] -> Syntax +syntaxForm1File :: [KnownPackage] -> Syntax syntaxForm1File ps = -- Note there's a bit of an inconsistency here vs the other syntax forms -- for files. For the single-part syntax the target has to point to a file @@ -1017,10 +1000,12 @@ -- all the other forms we don't require that. syntaxForm1 render $ \str1 fstatus1 -> expecting "file" str1 $ do - (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile - return (TargetComponent p (cinfoName c) (FileTarget filepath)) + (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) + -- always returns the KnownPackage case + <- matchPackageDirectoryPrefix ps fstatus1 + orNoThingIn "package" (display (packageName pinfoId)) $ do + (filepath, c) <- matchComponentFile pinfoComponents pkgfile + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) where render (TargetComponent _p _c (FileTarget f)) = [TargetStringFileStatus1 f noFileStatus] @@ -1062,32 +1047,44 @@ -- -- > cabal build foo:tests -- -syntaxForm2PackageFilter :: [PackageInfo] -> Syntax +syntaxForm2PackageFilter :: [KnownPackage] -> Syntax syntaxForm2PackageFilter ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 p <- matchPackage ps str1 fstatus1 kfilter <- matchComponentKindFilter str2 - return (TargetPackage TargetExplicitNamed p (Just kfilter)) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) where - render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)] render _ = [] -- | Syntax: pkg : package name -- -- > cabal build pkg:foo -- -syntaxForm2NamespacePackage :: [PackageInfo] -> Syntax +syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax syntaxForm2NamespacePackage pinfo = syntaxForm2 render $ \str1 _fstatus1 str2 -> do guardNamespacePackage str1 guardPackageName str2 p <- matchPackage pinfo str2 noFileStatus - return (TargetPackage TargetExplicitNamed p Nothing) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) where - render (TargetPackage TargetExplicitNamed p Nothing) = + render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)] render _ = [] -- | Syntax: package : component @@ -1096,36 +1093,43 @@ -- > cabal build ./foo:foo -- > cabal build ./foo.cabal:foo -- -syntaxForm2PackageComponent :: [PackageInfo] -> Syntax +syntaxForm2PackageComponent :: [KnownPackage] -> Syntax syntaxForm2PackageComponent ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 guardComponentName str2 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - return (TargetComponent p (cinfoName c) WholeComponent) - --TODO: the error here ought to say there's no component by that name in - -- this package, and name the package + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + --TODO: the error here ought to say there's no component by that name in + -- this package, and name the package + KnownPackageName pn -> + let cn = mkUnqualComponentName str2 in + return (TargetComponentUnknown pn (Left cn) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] + render (TargetComponentUnknown pn (Left cn) WholeComponent) = + [TargetStringFileStatus2 (dispPN pn) noFileStatus (display cn)] render _ = [] -- | Syntax: namespace : component -- -- > cabal build lib:foo exe:foo -- -syntaxForm2KindComponent :: [ComponentInfo] -> Syntax +syntaxForm2KindComponent :: [KnownComponent] -> Syntax syntaxForm2KindComponent cs = syntaxForm2 render $ \str1 _fstatus1 str2 -> do ckind <- matchComponentKind str1 guardComponentName str2 c <- matchComponentKindAndName cs ckind str2 - return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent) + return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus2 (dispK c) noFileStatus (dispC p c)] + [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)] render _ = [] -- | Syntax: package : module @@ -1134,16 +1138,22 @@ -- > cabal build ./foo:Data.Foo -- > cabal build ./foo.cabal:Data.Foo -- -syntaxForm2PackageModule :: [PackageInfo] -> Syntax +syntaxForm2PackageModule :: [KnownPackage] -> Syntax syntaxForm2PackageModule ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 guardModuleName str2 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str2 - return (TargetComponent p (cinfoName c) (ModuleTarget m)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str2 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName pn -> do + m <- matchModuleNameUnknown str2 + -- We assume the primary library component of the package: + return (TargetComponentUnknown pn (Right CLibName) (ModuleTarget m)) where render (TargetComponent p _c (ModuleTarget m)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] @@ -1153,7 +1163,7 @@ -- -- > cabal build foo:Data.Foo -- -syntaxForm2ComponentModule :: [ComponentInfo] -> Syntax +syntaxForm2ComponentModule :: [KnownComponent] -> Syntax syntaxForm2ComponentModule cs = syntaxForm2 render $ \str1 _fstatus1 str2 -> do guardComponentName str1 @@ -1162,7 +1172,7 @@ orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str2 - return (TargetComponent (cinfoPackage c) (cinfoName c) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = @@ -1175,14 +1185,20 @@ -- > cabal build ./foo:Data/Foo.hs -- > cabal build ./foo.cabal:Data/Foo.hs -- -syntaxForm2PackageFile :: [PackageInfo] -> Syntax +syntaxForm2PackageFile :: [KnownPackage] -> Syntax syntaxForm2PackageFile ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - (filepath, c) <- matchComponentFile (pinfoComponents p) str2 - return (TargetComponent p (cinfoName c) (FileTarget filepath)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + (filepath, c) <- matchComponentFile pinfoComponents str2 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName pn -> + let filepath = str2 in + -- We assume the primary library component of the package: + return (TargetComponentUnknown pn (Right CLibName) (FileTarget filepath)) where render (TargetComponent p _c (FileTarget f)) = [TargetStringFileStatus2 (dispP p) noFileStatus f] @@ -1192,14 +1208,14 @@ -- -- > cabal build foo:Data/Foo.hs -- -syntaxForm2ComponentFile :: [ComponentInfo] -> Syntax +syntaxForm2ComponentFile :: [KnownComponent] -> Syntax syntaxForm2ComponentFile cs = syntaxForm2 render $ \str1 _fstatus1 str2 -> do guardComponentName str1 c <- matchComponentName cs str1 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str2 - return (TargetComponent (cinfoPackage c) (cinfoName c) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = @@ -1224,14 +1240,15 @@ [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)] render _ = [] -syntaxForm3MetaCwdFilter :: Syntax -syntaxForm3MetaCwdFilter = +syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax +syntaxForm3MetaCwdFilter ps = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do guardNamespaceMeta str1 guardNamespaceCwd str2 kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter)) + return (TargetPackage TargetImplicitCwd pids (Just kfilter)) where + pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] render _ = [] @@ -1240,17 +1257,23 @@ -- -- > cabal build :pkg:foo -- -syntaxForm3MetaNamespacePackage :: [PackageInfo] -> Syntax +syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax syntaxForm3MetaNamespacePackage pinfo = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do guardNamespaceMeta str1 guardNamespacePackage str2 guardPackageName str3 p <- matchPackage pinfo str3 noFileStatus - return (TargetPackage TargetExplicitNamed p Nothing) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) where - render (TargetPackage TargetExplicitNamed p Nothing) = + render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)] render _ = [] -- | Syntax: package : namespace : component @@ -1259,19 +1282,26 @@ -- > cabal build foo/:lib:foo -- > cabal build foo.cabal:lib:foo -- -syntaxForm3PackageKindComponent :: [PackageInfo] -> Syntax +syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax syntaxForm3PackageKindComponent ps = syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 ckind <- matchComponentKind str2 guardComponentName str3 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str3 - return (TargetComponent p (cinfoName c) WholeComponent) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str3 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in + return (TargetComponentUnknown pn (Right cn) WholeComponent) where render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus3 (dispP p) noFileStatus (dispK c) (dispC p c)] + [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] + render (TargetComponentUnknown pn (Right c) WholeComponent) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)] render _ = [] -- | Syntax: package : component : module @@ -1280,29 +1310,37 @@ -- > cabal build foo/:foo:Data.Foo -- > cabal build foo.cabal:foo:Data.Foo -- -syntaxForm3PackageComponentModule :: [PackageInfo] -> Syntax +syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax syntaxForm3PackageComponentModule ps = syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 guardComponentName str2 guardModuleName str3 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (TargetComponent p (cinfoName c) (ModuleTarget m)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName pn -> do + let cn = mkUnqualComponentName str2 + m <- matchModuleNameUnknown str3 + return (TargetComponentUnknown pn (Left cn) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] + render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)] render _ = [] -- | Syntax: namespace : component : module -- -- > cabal build lib:foo:Data.Foo -- -syntaxForm3KindComponentModule :: [ComponentInfo] -> Syntax +syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax syntaxForm3KindComponentModule cs = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do ckind <- matchComponentKind str1 @@ -1312,11 +1350,11 @@ orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str3 - return (TargetComponent (cinfoPackage c) (cinfoName c) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) (dispM m)] + [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)] render _ = [] -- | Syntax: package : component : filename @@ -1325,27 +1363,35 @@ -- > cabal build foo/:foo:Data/Foo.hs -- > cabal build foo.cabal:foo:Data/Foo.hs -- -syntaxForm3PackageComponentFile :: [PackageInfo] -> Syntax +syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax syntaxForm3PackageComponentFile ps = syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 guardComponentName str2 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent p (cinfoName c) (FileTarget filepath)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName pn -> + let cn = mkUnqualComponentName str2 + filepath = str3 in + return (TargetComponentUnknown pn (Left cn) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] + render (TargetComponentUnknown pn (Left c) (FileTarget f)) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f] render _ = [] -- | Syntax: namespace : component : filename -- -- > cabal build lib:foo:Data/Foo.hs -- -syntaxForm3KindComponentFile :: [ComponentInfo] -> Syntax +syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax syntaxForm3KindComponentFile cs = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do ckind <- matchComponentKind str1 @@ -1353,29 +1399,35 @@ c <- matchComponentKindAndName cs ckind str2 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent (cinfoPackage c) (cinfoName c) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) f] + [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f] render _ = [] -syntaxForm3NamespacePackageFilter :: [PackageInfo] -> Syntax +syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax syntaxForm3NamespacePackageFilter ps = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do guardNamespacePackage str1 guardPackageName str2 p <- matchPackage ps str2 noFileStatus kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetExplicitNamed p (Just kfilter)) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) where - render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)] render _ = [] -- -syntaxForm4MetaNamespacePackageFilter :: [PackageInfo] -> Syntax +syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax syntaxForm4MetaNamespacePackageFilter ps = syntaxForm4 render $ \str1 str2 str3 str4 -> do guardNamespaceMeta str1 @@ -1383,17 +1435,23 @@ guardPackageName str3 p <- matchPackage ps str3 noFileStatus kfilter <- matchComponentKindFilter str4 - return (TargetPackage TargetExplicitNamed p (Just kfilter)) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) where - render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)] render _ = [] -- | Syntax: :pkg : package : namespace : component -- -- > cabal build :pkg:foo:lib:foo -- -syntaxForm5MetaNamespacePackageKindComponent :: [PackageInfo] -> Syntax +syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax syntaxForm5MetaNamespacePackageKindComponent ps = syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do guardNamespaceMeta str1 @@ -1402,12 +1460,19 @@ ckind <- matchComponentKind str4 guardComponentName str5 p <- matchPackage ps str3 noFileStatus - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str5 - return (TargetComponent p (cinfoName c) WholeComponent) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in + return (TargetComponentUnknown pn (Right cn) WholeComponent) where render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus5 "" "pkg" (dispP p) (dispK c) (dispC p c)] + [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] + render (TargetComponentUnknown pn (Right c) WholeComponent) = + [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)] render _ = [] -- | Syntax: :pkg : package : namespace : component : module : module @@ -1415,7 +1480,7 @@ -- > cabal build :pkg:foo:lib:foo:module:Data.Foo -- syntaxForm7MetaNamespacePackageKindComponentNamespaceModule - :: [PackageInfo] -> Syntax + :: [KnownPackage] -> Syntax syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do guardNamespaceMeta str1 @@ -1425,17 +1490,27 @@ guardComponentName str5 guardNamespaceModule str6 p <- matchPackage ps str3 noFileStatus - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str5 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str7 - return (TargetComponent p (cinfoName c) (ModuleTarget m)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str7 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName pn -> do + let cn = mkComponentName pn ckind (mkUnqualComponentName str2) + m <- matchModuleNameUnknown str7 + return (TargetComponentUnknown pn (Right cn) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispK c) (dispC p c) + (dispCK c) (dispC p c) "module" (dispM m)] + render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) = + [TargetStringFileStatus7 "" "pkg" (dispPN pn) + (dispCK c) (dispC' pn c) + "module" (dispM m)] render _ = [] -- | Syntax: :pkg : package : namespace : component : file : filename @@ -1443,7 +1518,7 @@ -- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs -- syntaxForm7MetaNamespacePackageKindComponentNamespaceFile - :: [PackageInfo] -> Syntax + :: [KnownPackage] -> Syntax syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do guardNamespaceMeta str1 @@ -1453,16 +1528,26 @@ guardComponentName str5 guardNamespaceFile str6 p <- matchPackage ps str3 noFileStatus - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str5 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath,_) <- matchComponentFile [c] str7 - return (TargetComponent p (cinfoName c) (FileTarget filepath)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath,_) <- matchComponentFile [c] str7 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) + filepath = str7 in + return (TargetComponentUnknown pn (Right cn) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispK c) (dispC p c) + (dispCK c) (dispC p c) "file" f] + render (TargetComponentUnknown pn (Right c) (FileTarget f)) = + [TargetStringFileStatus7 "" "pkg" (dispPN pn) + (dispCK c) (dispC' pn c) + "file" f] render _ = [] @@ -1470,17 +1555,17 @@ -- Syntax utils -- -type Match1 = String -> FileStatus -> Match (TargetSelector PackageInfo) +type Match1 = String -> FileStatus -> Match TargetSelector type Match2 = String -> FileStatus -> String - -> Match (TargetSelector PackageInfo) + -> Match TargetSelector type Match3 = String -> FileStatus -> String -> String - -> Match (TargetSelector PackageInfo) + -> Match TargetSelector type Match4 = String -> String -> String -> String - -> Match (TargetSelector PackageInfo) + -> Match TargetSelector type Match5 = String -> String -> String -> String -> String - -> Match (TargetSelector PackageInfo) + -> Match TargetSelector type Match7 = String -> String -> String -> String -> String -> String -> String - -> Match (TargetSelector PackageInfo) + -> Match TargetSelector syntaxForm1 :: Renderer -> Match1 -> Syntax syntaxForm2 :: Renderer -> Match2 -> Syntax @@ -1531,12 +1616,24 @@ dispP :: Package p => p -> String dispP = display . packageName -dispC :: Package p => p -> ComponentName -> String -dispC = componentStringName +dispPN :: PackageName -> String +dispPN = display -dispK :: ComponentName -> String -dispK = showComponentKindShort . componentKind +dispC :: PackageId -> ComponentName -> String +dispC = componentStringName . packageName +dispC' :: PackageName -> ComponentName -> String +dispC' = componentStringName + +dispCN :: UnqualComponentName -> String +dispCN = display + +dispK :: ComponentKind -> String +dispK = showComponentKindShort + +dispCK :: ComponentName -> String +dispCK = dispK . componentKind + dispF :: ComponentKind -> String dispF = showComponentKindFilterShort @@ -1548,39 +1645,88 @@ -- Package and component info -- -data PackageInfo = PackageInfo { +data KnownTargets = KnownTargets { + knownPackagesAll :: [KnownPackage], + knownPackagesPrimary :: [KnownPackage], + knownPackagesOther :: [KnownPackage], + knownComponentsAll :: [KnownComponent], + knownComponentsPrimary :: [KnownComponent], + knownComponentsOther :: [KnownComponent] + } + deriving Show + +data KnownPackage = + KnownPackage { pinfoId :: PackageId, - pinfoLocation :: PackageLocation (), pinfoDirectory :: Maybe (FilePath, FilePath), pinfoPackageFile :: Maybe (FilePath, FilePath), - pinfoComponents :: [ComponentInfo] + pinfoComponents :: [KnownComponent] } - -- not instance of Show due to recursive construction + | KnownPackageName { + pinfoName :: PackageName + } + deriving Show -data ComponentInfo = ComponentInfo { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoPackage :: PackageInfo, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoCFiles :: [FilePath], - cinfoJsFiles :: [FilePath] +data KnownComponent = KnownComponent { + cinfoName :: ComponentName, + cinfoStrName :: ComponentStringName, + cinfoPackageId :: PackageId, + cinfoSrcDirs :: [FilePath], + cinfoModules :: [ModuleName], + cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) + cinfoCFiles :: [FilePath], + cinfoJsFiles :: [FilePath] } - -- not instance of Show due to recursive construction + deriving Show type ComponentStringName = String -instance Package PackageInfo where - packageId = pinfoId +knownPackageName :: KnownPackage -> PackageName +knownPackageName KnownPackage{pinfoId} = packageName pinfoId +knownPackageName KnownPackageName{pinfoName} = pinfoName -selectPackageInfo :: (Applicative m, Monad m) => DirActions m - -> SourcePackage (PackageLocation a) -> m PackageInfo -selectPackageInfo dirActions@DirActions{..} - SourcePackage { +emptyKnownTargets :: KnownTargets +emptyKnownTargets = KnownTargets [] [] [] [] [] [] + +getKnownTargets :: (Applicative m, Monad m) + => DirActions m + -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> m KnownTargets +getKnownTargets dirActions@DirActions{..} pkgs = do + pinfo <- mapM (collectKnownPackageInfo dirActions) pkgs + cwd <- getCurrentDirectory + let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo + return KnownTargets { + knownPackagesAll = pinfo, + knownPackagesPrimary = ppinfo, + knownPackagesOther = opinfo, + knownComponentsAll = allComponentsIn pinfo, + knownComponentsPrimary = allComponentsIn ppinfo, + knownComponentsOther = allComponentsIn opinfo + } + where + selectPrimaryPackage :: FilePath + -> [KnownPackage] + -> ([KnownPackage], [KnownPackage]) + selectPrimaryPackage cwd = partition isPkgDirCwd + where + isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) } + | dir == cwd = True + isPkgDirCwd _ = False + allComponentsIn ps = + [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ] + + +collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m + -> PackageSpecifier (SourcePackage (PackageLocation a)) + -> m KnownPackage +collectKnownPackageInfo _ (NamedPackage pkgname _props) = + return (KnownPackageName pkgname) +collectKnownPackageInfo dirActions@DirActions{..} + (SpecificSourcePackage SourcePackage { packageDescription = pkg, packageSource = loc - } = do + }) = do (pkgdir, pkgfile) <- case loc of --TODO: local tarballs, remote tarballs etc @@ -1596,38 +1742,34 @@ ) _ -> return (Nothing, Nothing) let pinfo = - PackageInfo { + KnownPackage { pinfoId = packageId pkg, - pinfoLocation = fmap (const ()) loc, pinfoDirectory = pkgdir, pinfoPackageFile = pkgfile, - pinfoComponents = selectComponentInfo pinfo + pinfoComponents = collectKnownComponentInfo (flattenPackageDescription pkg) } return pinfo -selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo] -selectComponentInfo pinfo pkg = - [ ComponentInfo { - cinfoName = componentName c, - cinfoStrName = componentStringName pkg (componentName c), - cinfoPackage = pinfo, - cinfoSrcDirs = ordNub (hsSourceDirs bi), --- [ pkgroot srcdir --- | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo) --- , srcdir <- hsSourceDirs bi ], - cinfoModules = ordNub (componentModules c), - cinfoHsFiles = ordNub (componentHsFiles c), - cinfoCFiles = ordNub (cSources bi), - cinfoJsFiles = ordNub (jsSources bi) +collectKnownComponentInfo :: PackageDescription -> [KnownComponent] +collectKnownComponentInfo pkg = + [ KnownComponent { + cinfoName = componentName c, + cinfoStrName = componentStringName (packageName pkg) (componentName c), + cinfoPackageId = packageId pkg, + cinfoSrcDirs = ordNub (hsSourceDirs bi), + cinfoModules = ordNub (componentModules c), + cinfoHsFiles = ordNub (componentHsFiles c), + cinfoCFiles = ordNub (cSources bi), + cinfoJsFiles = ordNub (jsSources bi) } | c <- pkgComponents pkg , let bi = componentBuildInfo c ] -componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName -componentStringName pkg CLibName = display (packageName pkg) +componentStringName :: PackageName -> ComponentName -> ComponentStringName +componentStringName pkgname CLibName = display pkgname componentStringName _ (CSubLibName name) = unUnqualComponentName name componentStringName _ (CFLibName name) = unUnqualComponentName name componentStringName _ (CExeName name) = unUnqualComponentName name @@ -1677,7 +1819,7 @@ guardNamespaceFile = guardToken ["file"] "'file' namespace" guardToken :: [String] -> String -> String -> Match () -guardToken tokens msg s +guardToken tokens msg s | caseFold s `elem` tokens = increaseConfidence | otherwise = matchErrorExpected msg s @@ -1694,7 +1836,7 @@ componentKind (CTestName _) = TestKind componentKind (CBenchName _) = BenchKind -cinfoKind :: ComponentInfo -> ComponentKind +cinfoKind :: KnownComponent -> ComponentKind cinfoKind = componentKind . cinfoName matchComponentKind :: String -> Match ComponentKind @@ -1787,25 +1929,32 @@ guardPackageFile str _ = matchErrorExpected "package .cabal file" str -matchPackage :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo +matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackage pinfo = \str fstatus -> orNoThingIn "project" "" $ matchPackageName pinfo str - (matchPackageDir pinfo str fstatus + (matchPackageNameUnknown str + <|> matchPackageDir pinfo str fstatus <|> matchPackageFile pinfo str fstatus) -matchPackageName :: [PackageInfo] -> String -> Match PackageInfo +matchPackageName :: [KnownPackage] -> String -> Match KnownPackage matchPackageName ps = \str -> do guard (validPackageName str) orNoSuchThing "package" str - (map (display . packageName) ps) $ + (map (display . knownPackageName) ps) $ increaseConfidenceFor $ - matchInexactly caseFold (display . packageName) ps str + matchInexactly caseFold (display . knownPackageName) ps str -matchPackageDir :: [PackageInfo] - -> String -> FileStatus -> Match PackageInfo +matchPackageNameUnknown :: String -> Match KnownPackage +matchPackageNameUnknown str = do + pn <- matchParse str + unknownMatch (KnownPackageName pn) + + +matchPackageDir :: [KnownPackage] + -> String -> FileStatus -> Match KnownPackage matchPackageDir ps = \str fstatus -> case fstatus of FileStatusExistsDir canondir -> @@ -1815,10 +1964,10 @@ _ -> mzero where dirs = [ ((dabs,drel),p) - | p@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ] + | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ] -matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo +matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackageFile ps = \str fstatus -> do case fstatus of FileStatusExistsFile canonfile -> @@ -1828,7 +1977,7 @@ _ -> mzero where files = [ ((fabs,frel),p) - | p@PackageInfo{ pinfoPackageFile = Just (fabs,frel) } <- ps ] + | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ] --TODO: test outcome when dir exists but doesn't match any known one @@ -1851,15 +2000,15 @@ || c == '_' || c == '-' || c == '\'' -matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo +matchComponentName :: [KnownComponent] -> String -> Match KnownComponent matchComponentName cs str = orNoSuchThing "component" str (map cinfoStrName cs) $ increaseConfidenceFor $ matchInexactly caseFold cinfoStrName cs str -matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String - -> Match ComponentInfo +matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String + -> Match KnownComponent matchComponentKindAndName cs ckind str = orNoSuchThing (showComponentKind ckind ++ " component") str (map render cs) @@ -1901,31 +2050,38 @@ $ matchInexactly caseFold (display . fst) ms str +matchModuleNameUnknown :: String -> Match ModuleName +matchModuleNameUnknown str = + expecting "module" str + $ increaseConfidenceFor + $ matchParse str + + ------------------------------ -- Matching file targets -- -matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus - -> Match (FilePath, PackageInfo) +matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus + -> Match (FilePath, KnownPackage) matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = increaseConfidenceFor $ matchDirectoryPrefix pkgdirs filepath where pkgdirs = [ (dir, p) - | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ] + | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ] matchPackageDirectoryPrefix _ _ = mzero -matchComponentFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) +matchComponentFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) matchComponentFile cs str = orNoSuchThing "file" str [] $ matchComponentModuleFile cs str <|> matchComponentOtherFile cs str -matchComponentOtherFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) +matchComponentOtherFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) matchComponentOtherFile cs = matchFile [ (file, c) @@ -1936,8 +2092,8 @@ ] -matchComponentModuleFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) +matchComponentModuleFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) matchComponentModuleFile cs str = do matchFile [ (normalise (d toFilePath m), c) @@ -1979,11 +2135,22 @@ -- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we -- can run a matcher against an input using 'findMatch'. -- -data Match a = NoMatch Confidence [MatchError] - | ExactMatch Confidence [a] - | InexactMatch Confidence [a] +data Match a = NoMatch !Confidence [MatchError] + | Match !MatchClass !Confidence [a] deriving Show +-- | The kind of match, inexact or exact. We keep track of this so we can +-- prefer exact over inexact matches. The 'Ord' here is important: we try +-- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom. +-- +data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package + -- name without it being a specific known package + | Inexact -- ^ Matches a known thing inexactly + -- e.g. matches a known package case insensitively + | Exact -- ^ Exactly matches a known thing, + -- e.g. matches a known package case sensitively + deriving (Show, Eq, Ord) + type Confidence = Int data MatchError = MatchErrorExpected String String -- thing got @@ -1993,12 +2160,11 @@ instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) - fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (Match m d xs) = Match m d (fmap f xs) instance Applicative Match where - pure a = ExactMatch 0 [a] + pure a = Match Exact 0 [a] (<*>) = ap instance Alternative Match where @@ -2006,13 +2172,20 @@ (<|>) = matchPlus instance Monad Match where - return = pure - NoMatch d ms >>= _ = NoMatch d ms - ExactMatch d xs >>= f = addDepth d - $ msum (map f xs) - InexactMatch d xs >>= f = addDepth d . forceInexact - $ msum (map f xs) + return = pure + NoMatch d ms >>= _ = NoMatch d ms + Match m d xs >>= f = + -- To understand this, it needs to be read in context with the + -- implementation of 'matchPlus' below + case msum (map f xs) of + Match m' d' xs' -> Match (min m m') (d + d') xs' + -- The minimum match class is the one we keep. The match depth is + -- tracked but not used in the Match case. + NoMatch d' ms -> NoMatch (d + d') ms + -- Here is where we transfer the depth we were keeping track of in + -- the Match case over to the NoMatch case where it finally gets used. + instance MonadPlus Match where mzero = empty mplus = matchPlus @@ -2022,15 +2195,6 @@ infixl 3 -addDepth :: Confidence -> Match a -> Match a -addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs -addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs -addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs - -forceInexact :: Match a -> Match a -forceInexact (ExactMatch d ys) = InexactMatch d ys -forceInexact m = m - -- | Combine two matchers. Exact matches are used over inexact matches -- but if we have multiple exact, or inexact then the we collect all the -- ambiguous matches. @@ -2038,20 +2202,16 @@ -- This operator is associative, has unit 'mzero' and is also commutative. -- matchPlus :: Match a -> Match a -> Match a -matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = - ExactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a -matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = - InexactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b -matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') - | d1 > d2 = a - | d1 < d2 = b - | otherwise = NoMatch d1 (ms ++ ms') +matchPlus a@(Match _ _ _ ) (NoMatch _ _) = a +matchPlus (NoMatch _ _ ) b@(Match _ _ _) = b +matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b) + | d_a > d_b = a -- We only really make use of the depth in the NoMatch case. + | d_a < d_b = b + | otherwise = NoMatch d_a (ms_a ++ ms_b) +matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b) + | m_a > m_b = a -- exact over inexact + | m_a < m_b = b -- exact over inexact + | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b) -- | Combine two matchers. This is similar to 'matchPlus' with the -- difference that an exact match from the left matcher shadows any exact @@ -2060,7 +2220,7 @@ -- This operator is associative, has unit 'mzero' and is not commutative. -- matchPlusShadowing :: Match a -> Match a -> Match a -matchPlusShadowing a@(ExactMatch _ _) _ = a +matchPlusShadowing a@(Match Exact _ _) _ = a matchPlusShadowing a b = matchPlus a b @@ -2088,26 +2248,28 @@ orNoThingIn _ _ m = m increaseConfidence :: Match () -increaseConfidence = ExactMatch 1 [()] +increaseConfidence = Match Exact 1 [()] increaseConfidenceFor :: Match a -> Match a increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a -nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs -nubMatchesBy eq (ExactMatch d xs) = ExactMatch d (nubBy eq xs) -nubMatchesBy eq (InexactMatch d xs) = InexactMatch d (nubBy eq xs) +nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs +nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs) -- | Lift a list of matches to an exact match. -- exactMatches, inexactMatches :: [a] -> Match a exactMatches [] = mzero -exactMatches xs = ExactMatch 0 xs +exactMatches xs = Match Exact 0 xs inexactMatches [] = mzero -inexactMatches xs = InexactMatch 0 xs +inexactMatches xs = Match Inexact 0 xs +unknownMatch :: a -> Match a +unknownMatch x = Match Unknown 0 [x] + tryEach :: [a] -> Match a tryEach = exactMatches @@ -2122,15 +2284,18 @@ -- findMatch :: Match a -> MaybeAmbiguous a findMatch match = case match of - NoMatch _ msgs -> None msgs - ExactMatch _ [x] -> Unambiguous x - InexactMatch _ [x] -> Unambiguous x - ExactMatch _ [] -> error "findMatch: impossible: ExactMatch []" - InexactMatch _ [] -> error "findMatch: impossible: InexactMatch []" - ExactMatch _ xs -> Ambiguous True xs - InexactMatch _ xs -> Ambiguous False xs + NoMatch _ msgs -> None msgs + Match _ _ [x] -> Unambiguous x + Match m d [] -> error $ "findMatch: impossible: " ++ show match' + where match' = Match m d [] :: Match () + -- TODO: Maybe use Data.List.NonEmpty inside + -- Match so that this case would be correct + -- by construction? + Match m _ xs -> Ambiguous m xs -data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a] +data MaybeAmbiguous a = None [MatchError] + | Unambiguous a + | Ambiguous MatchClass [a] deriving Show @@ -2172,7 +2337,10 @@ -- the map of canonicalised keys to groups of inexact matches m' = Map.mapKeysWith (++) cannonicalise m +matchParse :: Text a => String -> Match a +matchParse = maybe mzero return . simpleParse + ------------------------------ -- Utils -- @@ -2180,25 +2348,42 @@ caseFold :: String -> String caseFold = lowercase +-- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the +-- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's +-- primary library from named private libraries. +-- +mkComponentName :: PackageName + -> ComponentKind + -> UnqualComponentName + -> ComponentName +mkComponentName pkgname ckind ucname = + case ckind of + LibKind + | packageNameToUnqualComponentName pkgname == ucname + -> CLibName + | otherwise -> CSubLibName ucname + FLibKind -> CFLibName ucname + ExeKind -> CExeName ucname + TestKind -> CTestName ucname + BenchKind -> CBenchName ucname + ------------------------------ -- Example inputs -- {- -ex1pinfo :: [PackageInfo] +ex1pinfo :: [KnownPackage] ex1pinfo = [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $ - PackageInfo { + KnownPackage { pinfoId = PackageIdentifier (mkPackageName "foo") (mkVersion [1]), - pinfoLocation = LocalUnpackedPackage "/the/foo", pinfoDirectory = Just ("/the/foo", "foo"), pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"), pinfoComponents = [] } - , PackageInfo { + , KnownPackage { pinfoId = PackageIdentifier (mkPackageName "bar") (mkVersion [1]), - pinfoLocation = LocalUnpackedPackage "/the/foo", pinfoDirectory = Just ("/the/bar", "bar"), pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"), pinfoComponents = [] @@ -2208,7 +2393,7 @@ addComponent n ds ms p = p { pinfoComponents = - ComponentInfo n (componentStringName (pinfoId p) n) + KnownComponent n (componentStringName (pinfoId p) n) p ds (map mkMn ms) [] [] [] : pinfoComponents p @@ -2232,13 +2417,13 @@ -} {- -ex_cs :: [ComponentInfo] +ex_cs :: [KnownComponent] ex_cs = [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) ] where - mkC n ds ms = ComponentInfo n (componentStringName n) ds (map mkMn ms) + mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms) mkMn :: String -> ModuleName mkMn = fromJust . simpleParse pkgid :: PackageIdentifier diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -18,11 +18,6 @@ UserTarget(..), readUserTargets, - -- * Package specifiers - PackageSpecifier(..), - pkgSpecifierTarget, - pkgSpecifierConstraints, - -- * Resolving user targets to package specifiers resolveUserTargets, @@ -60,11 +55,9 @@ , PackageIdentifier(..), packageName, packageVersion ) import Distribution.Types.Dependency import Distribution.Client.Types - ( PackageLocation(..) - , ResolvedPkgLoc, UnresolvedSourcePackage ) + ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage + , PackageSpecifier(..) ) -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackagePath @@ -82,7 +75,7 @@ ( RepoContext(..) ) import Distribution.PackageDescription - ( GenericPackageDescription, parseFlagAssignment ) + ( GenericPackageDescription, parseFlagAssignment, nullFlagAssignment ) import Distribution.Version ( nullVersion, thisVersion, anyVersion, isAnyVersion ) import Distribution.Text @@ -91,16 +84,8 @@ import Distribution.Simple.Utils ( die', warn, lowercase ) -#ifdef CABAL_PARSEC import Distribution.PackageDescription.Parsec ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe ) -#else -import Distribution.PackageDescription.Parse - ( readGenericPackageDescription, parseGenericPackageDescription, ParseResult(..) ) -import Distribution.Simple.Utils - ( fromUTF8, ignoreBOM ) -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -#endif -- import Data.List ( find, nub ) import Data.Either @@ -179,46 +164,6 @@ -- ------------------------------------------------------------ --- * Package specifier --- ------------------------------------------------------------ - --- | A fully or partially resolved reference to a package. --- -data PackageSpecifier pkg = - - -- | A partially specified reference to a package (either source or - -- installed). It is specified by package name and optionally some - -- required properties. Use a dependency resolver to pick a specific - -- package satisfying these properties. - -- - NamedPackage PackageName [PackageProperty] - - -- | A fully specified source package. - -- - | SpecificSourcePackage pkg - deriving (Eq, Show, Generic) - -instance Binary pkg => Binary (PackageSpecifier pkg) - -pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName -pkgSpecifierTarget (NamedPackage name _) = name -pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg - -pkgSpecifierConstraints :: Package pkg - => PackageSpecifier pkg -> [LabeledPackageConstraint] -pkgSpecifierConstraints (NamedPackage name props) = map toLpc props - where - toLpc prop = LabeledPackageConstraint - (PackageConstraint (scopeToplevel name) prop) - ConstraintSourceUserTarget -pkgSpecifierConstraints (SpecificSourcePackage pkg) = - [LabeledPackageConstraint pc ConstraintSourceUserTarget] - where - pc = PackageConstraint - (scopeToplevel $ packageName pkg) - (PackagePropertyVersion $ thisVersion (packageVersion pkg)) - --- ------------------------------------------------------------ -- * Parsing and checking user targets -- ------------------------------------------------------------ @@ -444,7 +389,7 @@ , let props = [ PackagePropertyVersion vrange | not (isAnyVersion vrange) ] ++ [ PackagePropertyFlags flags - | not (null flags) ] ] + | not (nullFlagAssignment flags) ] ] UserTargetLocalDir dir -> return [ PackageTargetLocation (LocalUnpackedPackage dir) ] @@ -558,15 +503,8 @@ _ -> False parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription -#ifdef CABAL_PARSEC parsePackageDescription' bs = parseGenericPackageDescriptionMaybe (BS.toStrict bs) -#else - parsePackageDescription' content = - case parseGenericPackageDescription . ignoreBOM . fromUTF8 . BS.Char8.unpack $ content of - ParseOk _ pkg -> Just pkg - _ -> Nothing -#endif -- ------------------------------------------------------------ -- * Checking package targets @@ -629,10 +567,13 @@ case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of [] -> return () ambiguities -> die' verbosity $ unlines - [ "The package name '" ++ display name - ++ "' is ambiguous. It could be: " - ++ intercalate ", " (map display matches) - | (name, matches) <- ambiguities ] + [ "There is no package named '" ++ display name ++ "'. " + ++ (if length matches > 1 + then "However, the following package names exist: " + else "However, the following package name exists: ") + ++ intercalate ", " [ "'" ++ display m ++ "'" | m <- matches] + ++ "." + | (name, matches) <- ambiguities ] case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of [] -> return () @@ -651,19 +592,22 @@ data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] --- | Given a package name and a list of matching names, figure out which one it --- might be referring to. If there is an exact case-sensitive match then that's --- ok. If it matches just one package case-insensitively then that's also ok. --- The only problem is if it matches multiple packages case-insensitively, in --- that case it is ambiguous. +-- | Given a package name and a list of matching names, figure out +-- which one it might be referring to. If there is an exact +-- case-sensitive match then that's ok (i.e. returned via +-- 'Unambiguous'). If it matches just one package case-insensitively +-- or if it matches multiple packages case-insensitively, in that case +-- the result is 'Ambiguous'. -- +-- Note: Before cabal 2.2, when only a single package matched +-- case-insensitively it would be considered 'Unambigious'. +-- disambiguatePackageName :: PackageNameEnv -> PackageName -> MaybeAmbiguous PackageName disambiguatePackageName (PackageNameEnv pkgNameLookup) name = case nub (pkgNameLookup name) of [] -> None - [name'] -> Unambiguous name' names -> case find (name==) names of Just name' -> Unambiguous name' Nothing -> Ambiguous names diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -20,15 +20,19 @@ ----------------------------------------------------------------------------- module Distribution.Client.Types where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) + , PackageIdentifier(..), packageVersion, packageName , PackageInstalled(..), newSimpleUnitId ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo, installedComponentId, sourceComponentName ) import Distribution.PackageDescription ( FlagAssignment ) import Distribution.Version - ( VersionRange ) + ( VersionRange, nullVersion, thisVersion ) import Distribution.Types.ComponentId ( ComponentId ) import Distribution.Types.MungedPackageId @@ -39,7 +43,7 @@ import Distribution.Types.UnitId ( UnitId ) import Distribution.Types.PackageName - ( PackageName ) + ( PackageName, mkPackageName ) import Distribution.Types.ComponentName ( ComponentName(..) ) @@ -48,19 +52,22 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.SourcePackage import Distribution.Compat.Graph (IsNode(..)) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.ParseUtils (parseOptCommaList) import Distribution.Simple.Utils (ordNub) +import Distribution.Text (Text(..)) -import Data.Map (Map) import Network.URI (URI(..), URIAuth(..), nullURI) import Control.Exception ( Exception, SomeException ) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Distribution.Compat.Binary (Binary(..)) +import qualified Text.PrettyPrint as Disp newtype Username = Username { unUsername :: String } @@ -140,11 +147,11 @@ -- | A ConfiguredId is a package ID for a configured package. -- --- Once we configure a source package we know it's UnitId. It is still +-- Once we configure a source package we know its UnitId. It is still -- however useful in lots of places to also know the source ID for the package. -- We therefore bundle the two. -- --- An already installed package of course is also "configured" (all it's +-- An already installed package of course is also "configured" (all its -- configuration parameters and dependencies have been specified). data ConfiguredId = ConfiguredId { confSrcId :: PackageId @@ -208,7 +215,49 @@ -- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc + -- ------------------------------------------------------------ +-- * Package specifier +-- ------------------------------------------------------------ + +-- | A fully or partially resolved reference to a package. +-- +data PackageSpecifier pkg = + + -- | A partially specified reference to a package (either source or + -- installed). It is specified by package name and optionally some + -- required properties. Use a dependency resolver to pick a specific + -- package satisfying these properties. + -- + NamedPackage PackageName [PackageProperty] + + -- | A fully specified source package. + -- + | SpecificSourcePackage pkg + deriving (Eq, Show, Generic) + +instance Binary pkg => Binary (PackageSpecifier pkg) + +pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName +pkgSpecifierTarget (NamedPackage name _) = name +pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg + +pkgSpecifierConstraints :: Package pkg + => PackageSpecifier pkg -> [LabeledPackageConstraint] +pkgSpecifierConstraints (NamedPackage name props) = map toLpc props + where + toLpc prop = LabeledPackageConstraint + (PackageConstraint (scopeToplevel name) prop) + ConstraintSourceUserTarget +pkgSpecifierConstraints (SpecificSourcePackage pkg) = + [LabeledPackageConstraint pc ConstraintSourceUserTarget] + where + pc = PackageConstraint + (ScopeTarget $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) + + +-- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------ @@ -319,6 +368,11 @@ instance Binary Repo -- | Check if this is a remote repo +isRepoRemote :: Repo -> Bool +isRepoRemote RepoLocal{} = False +isRepoRemote _ = True + +-- | Extract @RemoteRepo@ from @Repo@ if remote. maybeRepoRemote :: Repo -> Maybe RemoteRepo maybeRepoRemote (RepoLocal _localDir) = Nothing maybeRepoRemote (RepoRemote r _localDir) = Just r @@ -370,3 +424,167 @@ instance Binary SomeException where put _ = return () get = fail "cannot serialise exceptions" + + +-- ------------------------------------------------------------ +-- * --allow-newer/--allow-older +-- ------------------------------------------------------------ + +-- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled, +-- it may make sense to move these definitions to the Solver.Types +-- module + +-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag) +newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps } + deriving (Eq, Read, Show, Generic) + +-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag) +newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps } + deriving (Eq, Read, Show, Generic) + +-- | Generic data type for policy when relaxing bounds in dependencies. +-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending +-- on whether or not you are relaxing an lower or upper bound +-- (respectively). +data RelaxDeps = + + -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages. + -- + -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all + -- dependencies, never choose versions newer (resp. older) than allowed. + RelaxDepsSome [RelaxedDep] + + -- | Ignore upper (resp. lower) bounds in dependencies on all packages. + -- + -- __Note__: This is should be semantically equivalent to + -- + -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] + -- + -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep') + | RelaxDepsAll + deriving (Eq, Read, Show, Generic) + +-- | Dependencies can be relaxed either for all packages in the install plan, or +-- only for some packages. +data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject + deriving (Eq, Read, Show, Generic) + +-- | Specify the scope of a relaxation, i.e. limit which depending +-- packages are allowed to have their version constraints relaxed. +data RelaxDepScope = RelaxDepScopeAll + -- ^ Apply relaxation in any package + | RelaxDepScopePackage !PackageName + -- ^ Apply relaxation to in all versions of a package + | RelaxDepScopePackageId !PackageId + -- ^ Apply relaxation to a specific version of a package only + deriving (Eq, Read, Show, Generic) + +-- | Modifier for dependency relaxation +data RelaxDepMod = RelaxDepModNone -- ^ Default semantics + | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints + deriving (Eq, Read, Show, Generic) + +-- | Express whether to relax bounds /on/ @all@ packages, or a single package +data RelaxDepSubject = RelaxDepSubjectAll + | RelaxDepSubjectPkg !PackageName + deriving (Eq, Ord, Read, Show, Generic) + +instance Text RelaxedDep where + disp (RelaxedDep scope rdmod subj) = case scope of + RelaxDepScopeAll -> Disp.text "all:" Disp.<> modDep + RelaxDepScopePackage p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep + RelaxDepScopePackageId p0 -> disp p0 Disp.<> Disp.colon Disp.<> modDep + where + modDep = case rdmod of + RelaxDepModNone -> disp subj + RelaxDepModCaret -> Disp.char '^' Disp.<> disp subj + + parse = RelaxedDep <$> scopeP <*> modP <*> parse + where + -- "greedy" choices + scopeP = (pure RelaxDepScopeAll <* Parse.char '*' <* Parse.char ':') + Parse.<++ (pure RelaxDepScopeAll <* Parse.string "all:") + Parse.<++ (RelaxDepScopePackageId <$> pidP <* Parse.char ':') + Parse.<++ (RelaxDepScopePackage <$> parse <* Parse.char ':') + Parse.<++ (pure RelaxDepScopeAll) + + modP = (pure RelaxDepModCaret <* Parse.char '^') + Parse.<++ (pure RelaxDepModNone) + + -- | Stricter 'PackageId' parser which doesn't overlap with 'PackageName' parser + pidP = do + p0 <- parse + when (pkgVersion p0 == nullVersion) Parse.pfail + pure p0 + +instance Text RelaxDepSubject where + disp RelaxDepSubjectAll = Disp.text "all" + disp (RelaxDepSubjectPkg pn) = disp pn + + parse = (pure RelaxDepSubjectAll <* Parse.char '*') Parse.<++ pkgn + where + pkgn = do + pn <- parse + pure (if (pn == mkPackageName "all") + then RelaxDepSubjectAll + else RelaxDepSubjectPkg pn) + +instance Text RelaxDeps where + disp rd | not (isRelaxDeps rd) = Disp.text "none" + disp (RelaxDepsSome pkgs) = Disp.fsep . + Disp.punctuate Disp.comma . + map disp $ pkgs + disp RelaxDepsAll = Disp.text "all" + + parse = (const mempty <$> ((Parse.string "none" Parse.+++ + Parse.string "None") <* Parse.eof)) + Parse.<++ (const RelaxDepsAll <$> ((Parse.string "all" Parse.+++ + Parse.string "All" Parse.+++ + Parse.string "*") <* Parse.eof)) + Parse.<++ ( RelaxDepsSome <$> parseOptCommaList parse) + +instance Binary RelaxDeps +instance Binary RelaxDepMod +instance Binary RelaxDepScope +instance Binary RelaxDepSubject +instance Binary RelaxedDep +instance Binary AllowNewer +instance Binary AllowOlder + +-- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations +-- +-- Equivalent to @isRelaxDeps = (/= 'mempty')@ +isRelaxDeps :: RelaxDeps -> Bool +isRelaxDeps (RelaxDepsSome []) = False +isRelaxDeps (RelaxDepsSome (_:_)) = True +isRelaxDeps RelaxDepsAll = True + +-- | 'RelaxDepsAll' is the /absorbing element/ +instance Semigroup RelaxDeps where + -- identity element + RelaxDepsSome [] <> r = r + l@(RelaxDepsSome _) <> RelaxDepsSome [] = l + -- absorbing element + l@RelaxDepsAll <> _ = l + (RelaxDepsSome _) <> r@RelaxDepsAll = r + -- combining non-{identity,absorbing} elements + (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) + +-- | @'RelaxDepsSome' []@ is the /identity element/ +instance Monoid RelaxDeps where + mempty = RelaxDepsSome [] + mappend = (<>) + +instance Semigroup AllowNewer where + AllowNewer x <> AllowNewer y = AllowNewer (x <> y) + +instance Semigroup AllowOlder where + AllowOlder x <> AllowOlder y = AllowOlder (x <> y) + +instance Monoid AllowNewer where + mempty = AllowNewer mempty + mappend = (<>) + +instance Monoid AllowOlder where + mempty = AllowOlder mempty + mappend = (<>) diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -15,40 +15,48 @@ ( update ) where +import Distribution.Simple.Setup + ( fromFlag ) +import Distribution.Client.Compat.Directory + ( setModificationTime ) import Distribution.Client.Types ( Repo(..), RemoteRepo(..), maybeRepoRemote ) import Distribution.Client.HttpUtils ( DownloadResult(..) ) import Distribution.Client.FetchUtils ( downloadIndex ) +import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.IndexUtils - ( updateRepoIndexCache, Index(..) ) + ( updateRepoIndexCache, Index(..), writeIndexTimestamp + , currentIndexTimestamp, indexBaseName ) import Distribution.Client.JobControl ( newParallelJobControl, spawnJob, collectJob ) import Distribution.Client.Setup - ( RepoContext(..) ) + ( RepoContext(..), UpdateFlags(..) ) +import Distribution.Text + ( display ) import Distribution.Verbosity - ( Verbosity ) import Distribution.Simple.Utils - ( writeFileAtomic, warn, notice ) + ( writeFileAtomic, warn, notice, noticeNoWrap ) import qualified Data.ByteString.Lazy as BS import Distribution.Client.GZipUtils (maybeDecompress) -import System.FilePath (dropExtension) -import Data.Maybe (catMaybes) +import System.FilePath ((<.>), dropExtension) +import Data.Maybe (mapMaybe) import Data.Time (getCurrentTime) +import Control.Monad import qualified Hackage.Security.Client as Sec -- | 'update' downloads the package list from all known servers -update :: Verbosity -> RepoContext -> IO () -update verbosity repoCtxt | null (repoContextRepos repoCtxt) = do +update :: Verbosity -> UpdateFlags -> RepoContext -> IO () +update verbosity _ repoCtxt | null (repoContextRepos repoCtxt) = do warn verbosity $ "No remote package servers have been specified. Usually " ++ "you would have one specified in the config file." -update verbosity repoCtxt = do +update verbosity updateFlags repoCtxt = do let repos = repoContextRepos repoCtxt - remoteRepos = catMaybes (map maybeRepoRemote repos) + remoteRepos = mapMaybe maybeRepoRemote repos case remoteRepos of [] -> return () [remoteRepo] -> @@ -58,23 +66,30 @@ $ "Downloading the latest package lists from: " : map (("- " ++) . remoteRepoName) remoteRepos jobCtrl <- newParallelJobControl (length repos) - mapM_ (spawnJob jobCtrl . updateRepo verbosity repoCtxt) repos + mapM_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos mapM_ (\_ -> collectJob jobCtrl) repos -updateRepo :: Verbosity -> RepoContext -> Repo -> IO () -updateRepo verbosity repoCtxt repo = do +updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO () +updateRepo verbosity updateFlags repoCtxt repo = do transport <- repoContextGetTransport repoCtxt case repo of RepoLocal{..} -> return () RepoRemote{..} -> do downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir case downloadResult of - FileAlreadyInCache -> return () + FileAlreadyInCache -> + setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime FileDownloaded indexPath -> do writeFileAtomic (dropExtension indexPath) . maybeDecompress =<< BS.readFile indexPath updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do + let index = RepoIndex repoCtxt repo + -- NB: This may be a nullTimestamp if we've never updated before + current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo + -- NB: always update the timestamp, even if we didn't actually + -- download anything + writeIndexTimestamp index (fromFlag (updateIndexState updateFlags)) ce <- if repoContextIgnoreExpiry repoCtxt then Just `fmap` getCurrentTime else return Nothing @@ -83,6 +98,13 @@ -- (If all access to the cache goes through hackage-security this can go) case updated of Sec.NoUpdates -> - return () + setModificationTime (indexBaseName repo <.> "tar") =<< getCurrentTime Sec.HasUpdates -> - updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) + updateRepoIndexCache verbosity index + -- TODO: This will print multiple times if there are multiple + -- repositories: main problem is we don't have a way of updating + -- a specific repo. Once we implement that, update this. + when (current_ts /= nullTimestamp) $ + noticeNoWrap verbosity $ + "To revert to previous state run:\n" ++ + " cabal update --index-state='" ++ display current_ts ++ "'\n" diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -25,7 +25,7 @@ import qualified System.FilePath.Posix as FilePath.Posix (()) import System.Directory import Control.Monad (forM_, when, foldM) -import Data.Maybe (catMaybes) +import Data.Maybe (mapMaybe) import Data.Char (isSpace) type Auth = Maybe (String, String) @@ -170,7 +170,7 @@ Password password <- maybe promptPassword return mPassword let auth = (username, password) repos = repoContextRepos repoCtxt - remoteRepos = catMaybes (map maybeRepoRemote repos) + remoteRepos = mapMaybe maybeRepoRemote repos forM_ remoteRepos $ \remoteRepo -> do dotCabal <- defaultCabalDir let srcDir = dotCabal "reports" remoteRepoName remoteRepo diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs --- a/Distribution/Client/Utils.hs +++ b/Distribution/Client/Utils.hs @@ -3,8 +3,8 @@ module Distribution.Client.Utils ( MergeResult(..) , mergeBy, duplicates, duplicatesBy , readMaybe - , inDir, withEnv, logDirChange - , withExtraPathEnv + , inDir, withEnv, withEnvOverrides + , logDirChange, withExtraPathEnv , determineNumJobs, numberOfProcessors , removeExistingFile , withTempFileName @@ -33,6 +33,8 @@ import Data.Bits ( (.|.), shiftL, shiftR ) import System.FilePath +import Control.Monad + ( mapM, mapM_, zipWithM_ ) import Data.List ( groupBy ) import Foreign.C.Types ( CInt(..) ) @@ -132,6 +134,27 @@ m `Exception.finally` (case mb_old of Nothing -> unsetEnv k Just old -> setEnv k old) + +-- | Executes the action with a list of environment variables and +-- corresponding overrides, where +-- +-- * @'Just' v@ means \"set the environment variable's value to @v@\". +-- * 'Nothing' means \"unset the environment variable\". +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a +withEnvOverrides overrides m = do + mb_olds <- mapM lookupEnv envVars + mapM_ (uncurry update) overrides + m `Exception.finally` zipWithM_ update envVars mb_olds + where + envVars :: [String] + envVars = map fst overrides + + update :: String -> Maybe FilePath -> IO () + update var Nothing = unsetEnv var + update var (Just val) = setEnv var val -- | Executes the action, increasing the PATH environment -- in some way diff --git a/Distribution/Client/Win32SelfUpgrade.hs b/Distribution/Client/Win32SelfUpgrade.hs --- a/Distribution/Client/Win32SelfUpgrade.hs +++ b/Distribution/Client/Win32SelfUpgrade.hs @@ -17,7 +17,7 @@ -- | Windows inherited a design choice from DOS that while initially innocuous -- has rather unfortunate consequences. It maintains the invariant that every -- open file has a corresponding name on disk. One positive consequence of this --- is that an executable can always find it's own executable file. The downside +-- is that an executable can always find its own executable file. The downside -- is that a program cannot be deleted or upgraded while it is running without -- hideous workarounds. This module implements one such hideous workaround. -- diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs --- a/Distribution/Client/World.hs +++ b/Distribution/Client/World.hs @@ -29,9 +29,13 @@ getContents, ) where +import Prelude (sequence) +import Distribution.Client.Compat.Prelude hiding (getContents) + import Distribution.Types.Dependency import Distribution.PackageDescription - ( FlagAssignment, mkFlagName, unFlagName ) + ( FlagAssignment, mkFlagAssignment, unFlagAssignment + , mkFlagName, unFlagName ) import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils @@ -41,17 +45,15 @@ import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.Exception ( catchIO ) import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ( (<>), (<+>) ) import Data.Char as Char import Data.List - ( unionBy, deleteFirstsBy, nubBy ) + ( unionBy, deleteFirstsBy ) import System.IO.Error ( isDoesNotExistError ) import qualified Data.ByteString.Lazy.Char8 as B -import Prelude hiding (getContents) data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment @@ -122,21 +124,21 @@ instance Text WorldPkgInfo where - disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags + disp (WorldPkgInfo dep flags) = disp dep Disp.<+> dispFlags (unFlagAssignment flags) where dispFlags [] = Disp.empty dispFlags fs = Disp.text "--flags=" - <> Disp.doubleQuotes (flagAssToDoc fs) + <<>> Disp.doubleQuotes (flagAssToDoc fs) flagAssToDoc = foldr (\(fname,val) flagAssDoc -> (if not val then Disp.char '-' else Disp.empty) - Disp.<> Disp.text (unFlagName fname) + <<>> Disp.text (unFlagName fname) Disp.<+> flagAssDoc) Disp.empty parse = do dep <- parse Parse.skipSpaces - flagAss <- Parse.option [] parseFlagAssignment + flagAss <- Parse.option mempty parseFlagAssignment return $ WorldPkgInfo dep flagAss where parseFlagAssignment :: Parse.ReadP r FlagAssignment @@ -145,7 +147,7 @@ Parse.skipSpaces _ <- Parse.char '=' Parse.skipSpaces - inDoubleQuotes $ Parse.many1 flag + mkFlagAssignment <$> (inDoubleQuotes $ Parse.many1 flag) where inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') diff --git a/Distribution/Solver/Compat/Prelude.hs b/Distribution/Solver/Compat/Prelude.hs new file mode 100644 --- /dev/null +++ b/Distribution/Solver/Compat/Prelude.hs @@ -0,0 +1,19 @@ +-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +-- | This module does two things: +-- +-- * Acts as a compatiblity layer, like @base-compat@. +-- +-- * Provides commonly used imports. +-- +-- This module is a superset of "Distribution.Compat.Prelude" (which +-- this module re-exports) +-- +module Distribution.Solver.Compat.Prelude + ( module Distribution.Compat.Prelude.Internal + , Prelude.IO + ) where + +import Prelude (IO) +import Distribution.Compat.Prelude.Internal hiding (IO) diff --git a/Distribution/Solver/Modular.hs b/Distribution/Solver/Modular.hs --- a/Distribution/Solver/Modular.hs +++ b/Distribution/Solver/Modular.hs @@ -1,5 +1,5 @@ module Distribution.Solver.Modular - ( modularResolver, SolverConfig(..)) where + ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..)) where -- Here, we try to map between the external cabal-install solver -- interface and the internal interface that the solver actually @@ -9,25 +9,41 @@ -- and finally, we have to convert back the resulting install -- plan. -import Data.Map as M - ( fromListWith ) +import Prelude () +import Distribution.Client.Compat.Prelude + +import qualified Data.Map as M +import Data.Set (Set) +import Data.Ord import Distribution.Compat.Graph ( IsNode(..) ) +import Distribution.Compiler + ( CompilerInfo ) import Distribution.Solver.Modular.Assignment - ( toCPs ) + ( Assignment, toCPs ) import Distribution.Solver.Modular.ConfiguredConversion ( convCP ) +import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Flag +import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.IndexConversion ( convPIs ) import Distribution.Solver.Modular.Log - ( logToProgress ) + ( SolverFailure(..), logToProgress ) import Distribution.Solver.Modular.Package ( PN ) import Distribution.Solver.Modular.Solver - ( SolverConfig(..), solve ) + ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) +import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.DependencyResolver +import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.PackagePreferences +import Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb ) +import Distribution.Solver.Types.Progress +import Distribution.Solver.Types.Variable import Distribution.System ( Platform(..) ) import Distribution.Simple.Utils @@ -38,9 +54,8 @@ -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = - fmap (uncurry postprocess) $ -- convert install plan - logToProgress (solverVerbosity sc) (maxBackjumps sc) $ -- convert log format into progress format - solve sc cinfo idx pkgConfigDB pprefs gcs pns + fmap (uncurry postprocess) $ -- convert install plan + solve' sc cinfo idx pkgConfigDB pprefs gcs pns where -- Indices have to be converted into solver-specific uniform index. idx = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx @@ -58,3 +73,100 @@ -- Helper function to extract the PN from a constraint. pcName :: PackageConstraint -> PN pcName (PackageConstraint scope _) = scopeToPackageName scope + +-- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display +-- in the error case. +-- +-- When there is no solution, we produce the error message by rerunning the +-- solver but making it prefer the goals from the final conflict set from the +-- first run. We also set the backjump limit to 0, so that the log stops at the +-- first backjump and is relatively short. Preferring goals from the final +-- conflict set increases the probability that the log to the first backjump +-- contains package, flag, and stanza choices that are relevant to the final +-- failure. The solver shouldn't need to choose any packages that aren't in the +-- final conflict set. (For every variable in the final conflict set, the final +-- conflict set should also contain the variable that introduced that variable. +-- The solver can then follow that chain of variables in reverse order from the +-- user target to the conflict.) However, it is possible that the conflict set +-- contains unnecessary variables. +-- +-- Producing an error message when the solver reaches the backjump limit is more +-- complicated. There is no final conflict set, so we create one for the minimal +-- subtree containing the path that the solver took to the first backjump. This +-- conflict set helps explain why the solver reached the backjump limit, because +-- the first backjump contributes to reaching the backjump limit. Additionally, +-- the solver is much more likely to be able to finish traversing this subtree +-- before the backjump limit, since its size is linear (not exponential) in the +-- number of goal choices. We create it by pruning all children after the first +-- successful child under each node in the original tree, so that there is at +-- most one valid choice at each level. Then we use the final conflict set from +-- that run to generate an error message, as in the case where the solver found +-- that there was no solution. +-- +-- Using the full log from a rerun of the solver ensures that the log is +-- complete, i.e., it shows the whole chain of dependencies from the user +-- targets to the conflicting packages. +solve' :: SolverConfig + -> CompilerInfo + -> Index + -> PkgConfigDb + -> (PN -> PackagePreferences) + -> Map PN [LabeledPackageConstraint] + -> Set PN + -> Progress String String (Assignment, RevDepMap) +solve' sc cinfo idx pkgConfigDB pprefs gcs pns = + foldProgress Step createErrorMsg Done (runSolver sc) + where + runSolver :: SolverConfig + -> Progress String SolverFailure (Assignment, RevDepMap) + runSolver sc' = + logToProgress (solverVerbosity sc') (maxBackjumps sc') $ -- convert log format into progress format + solve sc' cinfo idx pkgConfigDB pprefs gcs pns + + createErrorMsg :: SolverFailure + -> Progress String String (Assignment, RevDepMap) + createErrorMsg (NoSolution cs msg) = + Fail $ rerunSolverForErrorMsg cs msg + createErrorMsg (BackjumpLimitReached msg) = + Step ("Backjump limit reached. Rerunning dependency solver to generate " + ++ "a final conflict set for the search tree containing the " + ++ "first backjump.") $ + foldProgress Step f Done $ + runSolver sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True } + where + f :: SolverFailure -> Progress String String (Assignment, RevDepMap) + f (NoSolution cs _) = Fail $ rerunSolverForErrorMsg cs msg + f (BackjumpLimitReached _) = + -- This case is possible when the number of goals involved in + -- conflicts is greater than the backjump limit. + Fail $ msg ++ "Failed to generate a summarized dependency solver " + ++ "log due to low backjump limit." + + rerunSolverForErrorMsg :: ConflictSet -> String -> String + rerunSolverForErrorMsg cs finalMsg = + let sc' = sc { + goalOrder = Just goalOrder' + , maxBackjumps = Just 0 + } + + -- Preferring goals from the conflict set takes precedence over the + -- original goal order. + goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) + + in unlines ("Could not resolve dependencies:" : messages (runSolver sc')) + ++ finalMsg + + messages :: Progress step fail done -> [step] + messages = foldProgress (:) (const []) (const []) + +-- | Goal ordering that chooses goals contained in the conflict set before +-- other goals. +preferGoalsFromConflictSet :: ConflictSet + -> Variable QPN -> Variable QPN -> Ordering +preferGoalsFromConflictSet cs = + comparing $ \v -> not $ CS.member (toVar v) cs + where + toVar :: Variable QPN -> Var QPN + toVar (PackageVar qpn) = P qpn + toVar (FlagVar qpn fn) = F (FN qpn fn) + toVar (StanzaVar qpn sn) = S (SN qpn sn) diff --git a/Distribution/Solver/Modular/Assignment.hs b/Distribution/Solver/Modular/Assignment.hs --- a/Distribution/Solver/Modular/Assignment.hs +++ b/Distribution/Solver/Modular/Assignment.hs @@ -1,23 +1,20 @@ module Distribution.Solver.Modular.Assignment ( Assignment(..) + , PAssignment , FAssignment , SAssignment - , PreAssignment(..) - , extend , toCPs ) where -import Control.Applicative -import Control.Monad +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (pi) + import Data.Array as A import Data.List as L import Data.Map as M import Data.Maybe -import Prelude hiding (pi) -import Language.Haskell.Extension (Extension, Language) - -import Distribution.PackageDescription (FlagAssignment) -- from Cabal +import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -29,17 +26,11 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.LabeledGraph import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.Version -- | A (partial) package assignment. Qualified package names -- are associated with instances. type PAssignment = Map QPN I --- | A (partial) package preassignment. Qualified package names --- are associated with constrained instances. Constrained instances --- record constraints about the instances that can still be chosen, --- and in the extreme case fix a concrete instance. -type PPreAssignment = Map QPN (CI QPN) type FAssignment = Map QFN Bool type SAssignment = Map QSN Bool @@ -47,55 +38,6 @@ data Assignment = A PAssignment FAssignment SAssignment deriving (Show, Eq) --- | A preassignment comprises knowledge about variables, but not --- necessarily fixed values. -data PreAssignment = PA PPreAssignment FAssignment SAssignment - --- | Extend a package preassignment. --- --- Takes the variable that causes the new constraints, a current preassignment --- and a set of new dependency constraints. --- --- We're trying to extend the preassignment with each dependency one by one. --- Each dependency is for a particular variable. We check if we already have --- constraints for that variable in the current preassignment. If so, we're --- trying to merge the constraints. --- --- Either returns a witness of the conflict that would arise during the merge, --- or the successfully extended assignment. -extend :: (Extension -> Bool) -- ^ is a given extension supported - -> (Language -> Bool) -- ^ is a given language supported - -> (PkgconfigName -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable - -> Var QPN - -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet, [Dep QPN]) PPreAssignment -extend extSupported langSupported pkgPresent var = foldM extendSingle - where - - extendSingle :: PPreAssignment -> Dep QPN - -> Either (ConflictSet, [Dep QPN]) PPreAssignment - extendSingle a (Ext ext ) = - if extSupported ext then Right a - else Left (varToConflictSet var, [Ext ext]) - extendSingle a (Lang lang) = - if langSupported lang then Right a - else Left (varToConflictSet var, [Lang lang]) - extendSingle a (Pkg pn vr) = - if pkgPresent pn vr then Right a - else Left (varToConflictSet var, [Pkg pn vr]) - extendSingle a (Dep is_exe qpn ci) = - let ci' = M.findWithDefault (Constrained []) qpn a - in case (\ x -> M.insert qpn x a) <$> merge ci' ci of - Left (c, (d, d')) -> Left (c, L.map (Dep is_exe qpn) (simplify (P qpn) d d')) - Right x -> Right x - - -- We're trying to remove trivial elements of the conflict. If we're just - -- making a choice pkg == instance, and pkg => pkg == instance is a part - -- of the conflict, then this info is clear from the context and does not - -- have to be repeated. - simplify v (Fixed _ var') c | v == var && var' == var = [c] - simplify v c (Fixed _ var') | v == var && var' == var = [c] - simplify _ c d = [c, d] - -- | Delivers an ordered list of fully configured packages. -- -- TODO: This function is (sort of) ok. However, there's an open bug @@ -124,14 +66,14 @@ -- Determine the flags per package, by walking over and regrouping the -- complete flag assignment by package. fapp :: Map QPN FlagAssignment - fapp = M.fromListWith (++) $ - L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $ + fapp = M.fromListWith mappend $ + L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $ M.toList $ fa -- Stanzas per package. sapp :: Map QPN [OptionalStanza] sapp = M.fromListWith (++) $ - L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $ + L.map (\ ((SN qpn sn), b) -> (qpn, if b then [sn] else [])) $ M.toList $ sa -- Dependencies per package. @@ -146,7 +88,7 @@ depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp in L.map (\ pi@(PI qpn _) -> CP pi - (M.findWithDefault [] qpn fapp) - (M.findWithDefault [] qpn sapp) + (M.findWithDefault mempty qpn fapp) + (M.findWithDefault mempty qpn sapp) (depp' qpn)) ps diff --git a/Distribution/Solver/Modular/Builder.hs b/Distribution/Solver/Modular/Builder.hs --- a/Distribution/Solver/Modular/Builder.hs +++ b/Distribution/Solver/Modular/Builder.hs @@ -1,5 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Solver.Modular.Builder (buildTree) where +module Distribution.Solver.Modular.Builder ( + buildTree + , splits -- for testing + ) where -- Building the search tree. -- @@ -18,18 +21,18 @@ import Data.List as L import Data.Map as M +import Data.Set as S import Prelude hiding (sequence, mapM) import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package -import Distribution.Solver.Modular.PSQ (PSQ) import qualified Distribution.Solver.Modular.PSQ as P import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.ComponentDeps (Component) +import Distribution.Solver.Types.ComponentDeps import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings @@ -43,11 +46,11 @@ -- | The state needed to build the search tree without creating any linked nodes. data BuildState = BS { - index :: Index, -- ^ information about packages and their dependencies - rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies - open :: PSQ (OpenGoal ()) (), -- ^ set of still open goals (flag and package goals) - next :: BuildType, -- ^ kind of node to generate next - qualifyOptions :: QualifyOptions -- ^ qualification options + index :: Index, -- ^ information about packages and their dependencies + rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies + open :: [OpenGoal], -- ^ set of still open goals (flag and package goals) + next :: BuildType, -- ^ kind of node to generate next + qualifyOptions :: QualifyOptions -- ^ qualification options } -- | Map of available linking targets. @@ -57,65 +60,65 @@ -- -- We also adjust the map of overall goals, and keep track of the -- reverse dependencies of each of the goals. -extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState +extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs where - go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState - go g o [] = s { rdeps = g, open = o } - go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons' ng () o) ngs + go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState + go g o [] = s { rdeps = g, open = o } + go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = + go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs -- Note: for 'Flagged' goals, we always insert, so later additions win. -- This is important, because in general, if a goal is inserted twice, -- the later addition will have better dependency information. - go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons' ng () o) ngs - go g o (ng@(OpenGoal (Simple (Dep _ qpn _) c) _gr) : ngs) - | qpn == qpn' = go g o ngs - -- we ignore self-dependencies at this point; TODO: more care may be needed + go g o ((Stanza sn@(SN qpn _) t) : ngs) = + go g (StanzaGoal sn t (flagGR qpn) : o) ngs + go g o ((Simple (LDep dr (Dep _ qpn _)) c) : ngs) + | qpn == qpn' = + -- We currently only add a self-dependency to the graph if it is + -- between a package and its setup script. The edge creates a cycle + -- and causes the solver to backtrack and choose a different + -- instance for the setup script. We may need to track other + -- self-dependencies once we implement component-based solving. + case c of + ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs + _ -> go g o ngs | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs - | otherwise = go (M.insert qpn [(c, qpn')] g) (cons' ng () o) ngs + | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs -- code above is correct; insert/adjust have different arg order - go g o ( (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs - go g o ( (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs - go g o ( (OpenGoal (Simple (Pkg _pn _vr)_) _gr) : ngs)= go g o ngs - - cons' = P.cons . forgetCompOpenGoal + go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs + go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs + go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs addIfAbsent :: Eq a => a -> [a] -> [a] addIfAbsent x xs = if x `elem` xs then xs else x : xs + -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by + -- its containing package. + flagGR :: qpn -> GoalReason qpn + flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) + -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly. -scopedExtendOpen :: QPN -> I -> QGoalReason -> FlaggedDeps Component PN -> FlagInfo -> +scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> BuildState -> BuildState -scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s +scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s where -- Qualify all package names qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps -- Introduce all package flags - qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs + qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs -- Combine new package and flag goals - gs = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps) + gs = qfdefs ++ qfdeps -- NOTE: -- -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially -- multiple times, both via the flag declaration and via dependencies. - -- The order is potentially important, because the occurrences via - -- dependencies may record flag-dependency information. After a number - -- of bugs involving computing this information incorrectly, however, - -- we're currently not using carefully computed inter-flag dependencies - -- anymore, but instead use 'simplifyVar' when computing conflict sets - -- to map all flags of one package to a single flag for conflict set - -- purposes, thereby treating them all as interdependent. - -- - -- If we ever move to a more clever algorithm again, then the line above - -- needs to be looked at very carefully, and probably be replaced by - -- more systematically computed flag dependency information. -- | Datatype that encodes what to build next data BuildType = - Goals -- ^ build a goal choice node - | OneGoal (OpenGoal ()) -- ^ build a node for this goal - | Instance QPN I PInfo QGoalReason -- ^ build a tree for a concrete instance - deriving Show + Goals -- ^ build a goal choice node + | OneGoal OpenGoal -- ^ build a node for this goal + | Instance QPN PInfo -- ^ build a tree for a concrete instance build :: Linker BuildState -> Tree () QGoalReason build = ana go @@ -129,23 +132,17 @@ -- the tree. We select each open goal in turn, and before we descend, remove -- it from the queue of open goals. addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) - | P.null gs = DoneF rdm () - | otherwise = GoalChoiceF rdm $ P.mapKeys close - $ P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' }) - $ P.splits gs + | L.null gs = DoneF rdm () + | otherwise = GoalChoiceF rdm $ P.fromList + $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) + $ splits gs -- If we have already picked a goal, then the choice depends on the kind -- of goal. -- -- For a package, we look up the instances available in the global info, -- and then handle each instance in turn. -addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Ext _ ) _) _ ) }) = - error "Distribution.Solver.Modular.Builder: addChildren called with Ext goal" -addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Lang _ ) _) _ ) }) = - error "Distribution.Solver.Modular.Builder: addChildren called with Lang goal" -addChildren (BS { index = _ , next = OneGoal (OpenGoal (Simple (Pkg _ _ ) _) _ ) }) = - error "Distribution.Solver.Modular.Builder: addChildren called with Pkg goal" -addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) = +addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = -- If the package does not exist in the index, we construct an emty PChoiceF node for it -- After all, we have no choices here. Alternatively, we could immediately construct -- a Fail node here, but that would complicate the construction of conflict sets. @@ -154,16 +151,16 @@ case M.lookup pn idx of Nothing -> PChoiceF qpn rdm gr (W.fromList []) Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> - ([], POption i Nothing, bs { next = Instance qpn i info gr })) + ([], POption i Nothing, bs { next = Instance qpn info })) (M.toList pis))) -- TODO: data structure conversion is rather ugly here -- For a flag, we create only two subtrees, and we create them in the order -- that is indicated by the flag default. -addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) = +addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) = FChoiceF qfn rdm gr weak m b (W.fromList - [([if b then 0 else 1], True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True )) t) bs) { next = Goals }), - ([if b then 1 else 0], False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False)) f) bs) { next = Goals })]) + [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }), + ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })]) where trivial = L.null t && L.null f weak = WeakOrTrivial $ unWeakOrTrivial w || trivial @@ -173,10 +170,10 @@ -- the stanza by replacing the False branch with failure) or preferences -- (try enabling the stanza if possible by moving the True branch first). -addChildren bs@(BS { rdeps = rdm, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) = +addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) = SChoiceF qsn rdm gr trivial (W.fromList - [([0], False, bs { next = Goals }), - ([1], True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn)) t) bs) { next = Goals })]) + [([0], False, bs { next = Goals }), + ([1], True, (extendOpen qpn t bs) { next = Goals })]) where trivial = WeakOrTrivial (L.null t) @@ -184,8 +181,8 @@ -- and furthermore we update the set of goals. -- -- TODO: We could inline this above. -addChildren bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) _gr }) = - addChildren ((scopedExtendOpen qpn i (PDependency (PI qpn i)) fdeps fdefs bs) +addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = + addChildren ((scopedExtendOpen qpn fdeps fdefs bs) { next = Goals }) {------------------------------------------------------------------------------- @@ -258,16 +255,44 @@ buildState = BS { index = idx , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) - , open = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns) + , open = L.map topLevelGoal qpns , next = Goals , qualifyOptions = defaultQualifyOptions idx } , linkingState = M.empty } where - -- Should a top-level goal allowed to be an executable style - -- dependency? Well, I don't think it would make much difference - topLevelGoal qpn = OpenGoal (Simple (Dep False {- not exe -} qpn (Constrained [])) ()) UserGoal + topLevelGoal qpn = PkgGoal qpn UserGoal - qpns | ind = makeIndependent igs + qpns | ind = L.map makeIndependent igs | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs + +{------------------------------------------------------------------------------- + Goals +-------------------------------------------------------------------------------} + +-- | Information needed about a dependency before it is converted into a Goal. +data OpenGoal = + FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason + | StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason + | PkgGoal QPN QGoalReason + +-- | Closes a goal, i.e., removes all the extraneous information that we +-- need only during the build phase. +close :: OpenGoal -> Goal QPN +close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr +close (StanzaGoal qsn _ gr) = Goal (S qsn) gr +close (PkgGoal qpn gr) = Goal (P qpn) gr + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Pairs each element of a list with the list resulting from removal of that +-- element from the original list. +splits :: [a] -> [(a, [a])] +splits = go id + where + go :: ([a] -> [a]) -> [a] -> [(a, [a])] + go _ [] = [] + go f (x : xs) = (x, f xs) : go (f . (x :)) xs diff --git a/Distribution/Solver/Modular/ConflictSet.hs b/Distribution/Solver/Modular/ConflictSet.hs --- a/Distribution/Solver/Modular/ConflictSet.hs +++ b/Distribution/Solver/Modular/ConflictSet.hs @@ -131,7 +131,7 @@ #endif Var QPN -> ConflictSet -> ConflictSet insert var cs = CS { - conflictSetToSet = S.insert (simplifyVar var) (conflictSetToSet cs) + conflictSetToSet = S.insert var (conflictSetToSet cs) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] #endif @@ -155,14 +155,14 @@ #endif Var QPN -> ConflictSet singleton var = CS { - conflictSetToSet = S.singleton (simplifyVar var) + conflictSetToSet = S.singleton var #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif } member :: Var QPN -> ConflictSet -> Bool -member var = S.member (simplifyVar var) . conflictSetToSet +member var = S.member var . conflictSetToSet filter :: #ifdef DEBUG_CONFLICT_SETS @@ -182,7 +182,7 @@ #endif [Var QPN] -> ConflictSet fromList vars = CS { - conflictSetToSet = S.fromList (map simplifyVar vars) + conflictSetToSet = S.fromList vars #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif diff --git a/Distribution/Solver/Modular/Cycles.hs b/Distribution/Solver/Modular/Cycles.hs --- a/Distribution/Solver/Modular/Cycles.hs +++ b/Distribution/Solver/Modular/Cycles.hs @@ -11,7 +11,6 @@ import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component) @@ -25,9 +24,9 @@ go :: TreeF d c (Tree d c) -> Tree d c go (PChoiceF qpn rdm gr cs) = PChoice qpn rdm gr $ fmap (checkChild qpn) cs - go (FChoiceF qfn@(FN (PI qpn _) _) rdm gr w m d cs) = + go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) = FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs - go (SChoiceF qsn@(SN (PI qpn _) _) rdm gr w cs) = + go (SChoiceF qsn@(SN qpn _) rdm gr w cs) = SChoice qsn rdm gr w $ fmap (checkChild qpn) cs go x = inn x diff --git a/Distribution/Solver/Modular/Dependency.hs b/Distribution/Solver/Modular/Dependency.hs --- a/Distribution/Solver/Modular/Dependency.hs +++ b/Distribution/Solver/Modular/Dependency.hs @@ -1,59 +1,46 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} -#ifdef DEBUG_CONFLICT_SETS -{-# LANGUAGE ImplicitParams #-} -#endif module Distribution.Solver.Modular.Dependency ( -- * Variables Var(..) - , simplifyVar - , varPI , showVar + , varPN -- * Conflict sets , ConflictSet , ConflictMap , CS.showConflictSet -- * Constrained instances , CI(..) - , merge -- * Flagged dependencies , FlaggedDeps , FlaggedDep(..) + , LDep(..) , Dep(..) - , showDep + , DependencyReason(..) + , showDependencyReason , flattenFlaggedDeps , QualifyOptions(..) , qualifyDeps , unqualifyDeps - -- ** Setting/forgetting components - , forgetCompOpenGoal - , setCompFlaggedDeps -- * Reverse dependency map , RevDepMap -- * Goals , Goal(..) , GoalReason(..) , QGoalReason - , ResetVar(..) , goalToVar - , goalVarToConflictSet , varToConflictSet - , goalReasonToVars - -- * Open goals - , OpenGoal(..) - , close + , goalReasonToCS + , dependencyReasonToCS ) where -import Prelude hiding (pi) - -import Data.Map (Map) -import qualified Data.List as L +import Prelude () +import qualified Data.Map as M +import qualified Data.Set as S +import Distribution.Client.Compat.Prelude hiding (pi) import Language.Haskell.Extension (Extension(..), Language(..)) -import Distribution.Text - import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package @@ -63,56 +50,16 @@ import Distribution.Solver.Types.ComponentDeps (Component(..)) import Distribution.Solver.Types.PackagePath - -#ifdef DEBUG_CONFLICT_SETS -import GHC.Stack (CallStack) -#endif +import Distribution.Types.UnqualComponentName {------------------------------------------------------------------------------- Constrained instances -------------------------------------------------------------------------------} --- | Constrained instance. If the choice has already been made, this is --- a fixed instance, and we record the package name for which the choice --- is for convenience. Otherwise, it is a list of version ranges paired with --- the goals / variables that introduced them. -data CI qpn = Fixed I (Var qpn) | Constrained [VROrigin qpn] - deriving (Eq, Show, Functor) - -showCI :: CI QPN -> String -showCI (Fixed i _) = "==" ++ showI i -showCI (Constrained vr) = showVR (collapse vr) - --- | Merge constrained instances. We currently adopt a lazy strategy for --- merging, i.e., we only perform actual checking if one of the two choices --- is fixed. If the merge fails, we return a conflict set indicating the --- variables responsible for the failure, as well as the two conflicting --- fragments. --- --- Note that while there may be more than one conflicting pair of version --- ranges, we only return the first we find. --- --- TODO: Different pairs might have different conflict sets. We're --- obviously interested to return a conflict that has a "better" conflict --- set in the sense the it contains variables that allow us to backjump --- further. We might apply some heuristics here, such as to change the --- order in which we check the constraints. -merge :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - CI QPN -> CI QPN -> Either (ConflictSet, (CI QPN, CI QPN)) (CI QPN) -merge c@(Fixed i g1) d@(Fixed j g2) - | i == j = Right c - | otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d)) -merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ... - where - go [] = Right c - go (d@(vr, g2) : vrs) - | checkVR vr v = go vrs - | otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, Constrained [d])) -merge c@(Constrained _) d@(Fixed _ _) = merge d c -merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss)) +-- | Constrained instance. It represents the allowed instances for a package, +-- which can be either a fixed instance or a version range. +data CI = Fixed I | Constrained VR + deriving (Eq, Show) {------------------------------------------------------------------------------- Flagged dependencies @@ -124,80 +71,68 @@ -- rather than having the dependencies indexed by component, each dependency -- defines what component it is in. -- --- However, top-level goals are also modelled as dependencies, but of course --- these don't actually belong in any component of any package. Therefore, we --- parameterize 'FlaggedDeps' and derived datatypes with a type argument that --- specifies whether or not we have a component: we only ever instantiate this --- type argument with @()@ for top-level goals, or 'Component' for everything --- else (we could express this as a kind at the type-level, but that would --- require a very recent GHC). --- --- Note however, crucially, that independent of the type parameters, the list --- of dependencies underneath a flag choice or stanza choices _always_ uses --- Component as the type argument. This is important: when we pick a value for --- a flag, we _must_ know what component the new dependencies belong to, or --- else we don't be able to construct fine-grained reverse dependencies. -type FlaggedDeps comp qpn = [FlaggedDep comp qpn] +-- Note that each dependency is associated with a Component. We must know what +-- component the dependencies belong to, or else we won't be able to construct +-- fine-grained reverse dependencies. +type FlaggedDeps qpn = [FlaggedDep qpn] -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. -data FlaggedDep comp qpn = +data FlaggedDep qpn = -- | Dependencies which are conditional on a flag choice. Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) -- | Dependencies which are conditional on whether or not a stanza -- (e.g., a test suite or benchmark) is enabled. | Stanza (SN qpn) (TrueFlaggedDeps qpn) - -- | Dependencies for which are always enabled, for the component - -- 'comp' (or requested for the user, if comp is @()@). - | Simple (Dep qpn) comp - deriving (Eq, Show) + -- | Dependencies which are always enabled, for the component 'comp'. + | Simple (LDep qpn) Component -- | Conversatively flatten out flagged dependencies -- -- NOTE: We do not filter out duplicates. -flattenFlaggedDeps :: FlaggedDeps Component qpn -> [(Dep qpn, Component)] +flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)] flattenFlaggedDeps = concatMap aux where - aux :: FlaggedDep Component qpn -> [(Dep qpn, Component)] + aux :: FlaggedDep qpn -> [(LDep qpn, Component)] aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f aux (Stanza _ t) = flattenFlaggedDeps t aux (Simple d c) = [(d, c)] -type TrueFlaggedDeps qpn = FlaggedDeps Component qpn -type FalseFlaggedDeps qpn = FlaggedDeps Component qpn - --- | Is this dependency on an executable -type IsExe = Bool +type TrueFlaggedDeps qpn = FlaggedDeps qpn +type FalseFlaggedDeps qpn = FlaggedDeps qpn --- | A dependency (constraint) associates a package name with a --- constrained instance. +-- | A 'Dep' labeled with the reason it was introduced. -- --- 'Dep' intentionally has no 'Functor' instance because the type variable +-- 'LDep' intentionally has no 'Functor' instance because the type variable -- is used both to record the dependencies as well as who's doing the -- depending; having a 'Functor' instance makes bugs where we don't distinguish --- these two far too likely. (By rights 'Dep' ought to have two type variables.) -data Dep qpn = Dep IsExe qpn (CI qpn) -- ^ dependency on a package (possibly for executable - | Ext Extension -- ^ dependency on a language extension - | Lang Language -- ^ dependency on a language version - | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package - deriving (Eq, Show) +-- these two far too likely. (By rights 'LDep' ought to have two type variables.) +data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) -showDep :: Dep QPN -> String -showDep (Dep is_exe qpn (Fixed i v) ) = - (if P qpn /= v then showVar v ++ " => " else "") ++ - showQPN qpn ++ - (if is_exe then " (exe) " else "") ++ "==" ++ showI i -showDep (Dep is_exe qpn (Constrained [(vr, v)])) = - showVar v ++ " => " ++ showQPN qpn ++ - (if is_exe then " (exe) " else "") ++ showVR vr -showDep (Dep is_exe qpn ci ) = - showQPN qpn ++ (if is_exe then " (exe) " else "") ++ showCI ci -showDep (Ext ext) = "requires " ++ display ext -showDep (Lang lang) = "requires " ++ display lang -showDep (Pkg pn vr) = "requires pkg-config package " - ++ display pn ++ display vr - ++ ", not found in the pkg-config database" +-- | A dependency (constraint) associates a package name with a constrained +-- instance. It can also represent other types of dependencies, such as +-- dependencies on language extensions. +data Dep qpn = Dep (Maybe UnqualComponentName) qpn CI -- ^ dependency on a package (possibly for executable) + | Ext Extension -- ^ dependency on a language extension + | Lang Language -- ^ dependency on a language version + | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package + deriving Functor +-- | The reason that a dependency is active. It identifies the package and any +-- flag and stanza choices that introduced the dependency. It contains +-- everything needed for creating ConflictSets or describing conflicts in solver +-- log messages. +data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza) + deriving (Functor, Eq, Show) + +-- | Print the reason that a dependency was introduced. +showDependencyReason :: DependencyReason QPN -> String +showDependencyReason (DependencyReason qpn flags stanzas) = + intercalate " " $ + showQPN qpn + : map (uncurry showFlagValue) (M.toList flags) + ++ map (\s -> showSBool s True) (S.toList stanzas) + -- | Options for goal qualification (used in 'qualifyDeps') -- -- See also 'defaultQualifyOptions' @@ -220,34 +155,37 @@ -- -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. -qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN +qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go where - go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN + go :: FlaggedDeps PN -> FlaggedDeps QPN go = map go1 - go1 :: FlaggedDep Component PN -> FlaggedDep Component QPN + go1 :: FlaggedDep PN -> FlaggedDep QPN go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) - go1 (Simple dep comp) = Simple (goD dep comp) comp + go1 (Simple dep comp) = Simple (goLDep dep comp) comp -- Suppose package B has a setup dependency on package A. -- This will be recorded as something like -- - -- > Dep "A" (Constrained [(AnyVersion, Goal (P "B") reason]) + -- > LDep (DependencyReason "B") (Dep Nothing "A" (Constrained AnyVersion)) -- -- Observe that when we qualify this dependency, we need to turn that -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier - -- to the goal or the goal reason chain. + -- to the DependencyReason. + goLDep :: LDep PN -> Component -> LDep QPN + goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp) + goD :: Dep PN -> Component -> Dep QPN goD (Ext ext) _ = Ext ext goD (Lang lang) _ = Lang lang goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep is_exe dep ci) comp - | is_exe = Dep is_exe (Q (PackagePath ns (QualExe pn dep)) dep) (fmap (Q pp) ci) - | qBase dep = Dep is_exe (Q (PackagePath ns (QualBase pn)) dep) (fmap (Q pp) ci) - | qSetup comp = Dep is_exe (Q (PackagePath ns (QualSetup pn)) dep) (fmap (Q pp) ci) - | otherwise = Dep is_exe (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) ci) + goD (Dep mExe dep ci) comp + | isJust mExe = Dep mExe (Q (PackagePath ns (QualExe pn dep)) dep) ci + | qBase dep = Dep mExe (Q (PackagePath ns (QualBase pn )) dep) ci + | qSetup comp = Dep mExe (Q (PackagePath ns (QualSetup pn )) dep) ci + | otherwise = Dep mExe (Q (PackagePath ns inheritedQ ) dep) ci -- If P has a setup dependency on Q, and Q has a regular dependency on R, then -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup @@ -278,56 +216,24 @@ -- what to link these dependencies to, we need to requalify @Q.B@ to become -- @Q'.B@; we do this by first removing all qualifiers and then calling -- 'qualifyDeps' again. -unqualifyDeps :: FlaggedDeps comp QPN -> FlaggedDeps comp PN +unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN unqualifyDeps = go where - go :: FlaggedDeps comp QPN -> FlaggedDeps comp PN + go :: FlaggedDeps QPN -> FlaggedDeps PN go = map go1 - go1 :: FlaggedDep comp QPN -> FlaggedDep comp PN + go1 :: FlaggedDep QPN -> FlaggedDep PN go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) - go1 (Simple dep comp) = Simple (goD dep) comp + go1 (Simple dep comp) = Simple (goLDep dep) comp - goD :: Dep QPN -> Dep PN - goD (Dep is_exe qpn ci) = Dep is_exe (unq qpn) (fmap unq ci) - goD (Ext ext) = Ext ext - goD (Lang lang) = Lang lang - goD (Pkg pn vr) = Pkg pn vr + goLDep :: LDep QPN -> LDep PN + goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep) unq :: QPN -> PN unq (Q _ pn) = pn {------------------------------------------------------------------------------- - Setting/forgetting the Component --------------------------------------------------------------------------------} - -forgetCompOpenGoal :: OpenGoal Component -> OpenGoal () -forgetCompOpenGoal = mapCompOpenGoal $ const () - -setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn -setCompFlaggedDeps = mapCompFlaggedDeps . const - -{------------------------------------------------------------------------------- - Auxiliary: Mapping over the Component goal - - We don't export these, because the only type instantiations for 'a' and 'b' - here should be () or Component. (We could express this at the type level - if we relied on newer versions of GHC.) --------------------------------------------------------------------------------} - -mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b -mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr - -mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn -mapCompFlaggedDeps = L.map . mapCompFlaggedDep - -mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn -mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo t f -mapCompFlaggedDep _ (Stanza sn t ) = Stanza sn t -mapCompFlaggedDep g (Simple pn a ) = Simple pn (g a) - -{------------------------------------------------------------------------------- Reverse dependency map -------------------------------------------------------------------------------} @@ -346,86 +252,34 @@ -- | Reason why a goal is being added to a goal set. data GoalReason qpn = - UserGoal - | PDependency (PI qpn) - | FDependency (FN qpn) Bool - | SDependency (SN qpn) + UserGoal -- introduced by a build target + | DependencyGoal (DependencyReason qpn) -- introduced by a package deriving (Eq, Show, Functor) type QGoalReason = GoalReason QPN -class ResetVar f where - resetVar :: Var qpn -> f qpn -> f qpn - -instance ResetVar CI where - resetVar v (Fixed i _) = Fixed i v - resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs) - -instance ResetVar Dep where - resetVar v (Dep is_exe qpn ci) = Dep is_exe qpn (resetVar v ci) - resetVar _ (Ext ext) = Ext ext - resetVar _ (Lang lang) = Lang lang - resetVar _ (Pkg pn vr) = Pkg pn vr - -instance ResetVar Var where - resetVar = const - goalToVar :: Goal a -> Var a goalToVar (Goal v _) = v --- | Compute a singleton conflict set from a goal, containing just --- the goal variable. --- --- NOTE: This is just a call to 'varToConflictSet' under the hood; --- the 'GoalReason' is ignored. -goalVarToConflictSet :: Goal QPN -> ConflictSet -goalVarToConflictSet (Goal g _gr) = varToConflictSet g - -- | Compute a singleton conflict set from a 'Var' varToConflictSet :: Var QPN -> ConflictSet varToConflictSet = CS.singleton --- | A goal reason is mostly just a variable paired with the --- decision we made for that variable (except for user goals, --- where we cannot really point to a solver variable). This --- function drops the decision and recovers the list of --- variables (which will be empty or contain one element). --- -goalReasonToVars :: GoalReason qpn -> [Var qpn] -goalReasonToVars UserGoal = [] -goalReasonToVars (PDependency (PI qpn _)) = [P qpn] -goalReasonToVars (FDependency qfn _) = [F qfn] -goalReasonToVars (SDependency qsn) = [S qsn] - -{------------------------------------------------------------------------------- - Open goals --------------------------------------------------------------------------------} - --- | For open goals as they occur during the build phase, we need to store --- additional information about flags. -data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReason - deriving (Eq, Show) - --- | Closes a goal, i.e., removes all the extraneous information that we --- need only during the build phase. -close :: OpenGoal comp -> Goal QPN -close (OpenGoal (Simple (Dep _ qpn _) _) gr) = Goal (P qpn) gr -close (OpenGoal (Simple (Ext _) _) _ ) = - error "Distribution.Solver.Modular.Dependency.close: called on Ext goal" -close (OpenGoal (Simple (Lang _) _) _ ) = - error "Distribution.Solver.Modular.Dependency.close: called on Lang goal" -close (OpenGoal (Simple (Pkg _ _) _) _ ) = - error "Distribution.Solver.Modular.Dependency.close: called on Pkg goal" -close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr -close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr - -{------------------------------------------------------------------------------- - Version ranges paired with origins --------------------------------------------------------------------------------} +goalReasonToCS :: GoalReason QPN -> ConflictSet +goalReasonToCS UserGoal = CS.empty +goalReasonToCS (DependencyGoal dr) = dependencyReasonToCS dr -type VROrigin qpn = (VR, Var qpn) +-- | This function returns the solver variables responsible for the dependency. +-- It drops the flag and stanza values, which are only needed for log messages. +dependencyReasonToCS :: DependencyReason QPN -> ConflictSet +dependencyReasonToCS (DependencyReason qpn flags stanzas) = + CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) + where + -- Filter out any flags that introduced the dependency with both values. + -- They don't need to be included in the conflict set, because changing the + -- flag value can't remove the dependency. + flagVars :: [Var QPN] + flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth] --- | Helper function to collapse a list of version ranges with origins into --- a single, simplified, version range. -collapse :: [VROrigin qpn] -> VR -collapse = simplifyVR . L.foldr ((.&&.) . fst) anyVR + stanzaToVar :: Stanza -> Var QPN + stanzaToVar = S . SN qpn diff --git a/Distribution/Solver/Modular/Explore.hs b/Distribution/Solver/Modular/Explore.hs --- a/Distribution/Solver/Modular/Explore.hs +++ b/Distribution/Solver/Modular/Explore.hs @@ -21,11 +21,10 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..)) --- | This function takes the variable we're currently considering, an --- initial conflict set and a --- list of children's logs. Each log yields either a solution or a --- conflict set. The result is a combined log for the parent node that --- has explored a prefix of the children. +-- | This function takes the variable we're currently considering, a +-- last conflict set and a list of children's logs. Each log yields +-- either a solution or a conflict set. The result is a combined log for +-- the parent node that has explored a prefix of the children. -- -- We can stop traversing the children's logs if we find an individual -- conflict set that does not contain the current variable. In this @@ -38,7 +37,7 @@ -- return it immediately. If all children contain conflict sets, we can -- take the union as the combined conflict set. -- --- The initial conflict set corresponds to the justification that we +-- The last conflict set corresponds to the justification that we -- have to choose this goal at all. There is a reason why we have -- introduced the goal in the first place, and this reason is in conflict -- with the (virtual) option not to choose anything for the current @@ -47,8 +46,8 @@ backjump :: EnableBackjumping -> Var QPN -> ConflictSet -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a) -> ConflictMap -> ConflictSetLog a -backjump (EnableBackjumping enableBj) var initial xs = - F.foldr combine logBackjump xs initial +backjump (EnableBackjumping enableBj) var lastCS xs = + F.foldr combine avoidGoal xs CS.empty where combine :: forall a . (ConflictMap -> ConflictSetLog a) -> (ConflictSet -> ConflictMap -> ConflictSetLog a) @@ -60,11 +59,15 @@ | enableBj && not (var `CS.member` cs) = logBackjump cs cm' | otherwise = f (csAcc `CS.union` cs) cm' + -- This function represents the option to not choose a value for this goal. + avoidGoal :: ConflictSet -> ConflictMap -> ConflictSetLog a + avoidGoal cs !cm = logBackjump (cs `CS.union` lastCS) (updateCM lastCS cm) + -- 'lastCS' instead of 'cs' here ---^ + -- since we do not want to double-count the + -- additionally accumulated conflicts. + logBackjump :: ConflictSet -> ConflictMap -> ConflictSetLog a - logBackjump cs !cm = failWith (Failure cs Backjump) (cs, updateCM initial cm) - -- 'intial' instead of 'cs' here ---^ - -- since we do not want to double-count the - -- additionally accumulated conflicts. + logBackjump cs cm = failWith (Failure cs Backjump) (cs, cm) type ConflictSetLog = RetryLog Message (ConflictSet, ConflictMap) @@ -147,16 +150,16 @@ -- always have to consider that we could perhaps make choices that would -- avoid the existence of the goal completely. -- --- Whenever we actual introduce a choice in the tree, we have already established +-- Whenever we actually introduce a choice in the tree, we have already established -- that the goal cannot be avoided. This is tracked in the "goal reason". -- The choice to avoid the goal therefore is a conflict between the goal itself -- and its goal reason. We build this set here, and pass it to the 'backjump' --- function as the initial conflict set. +-- function as the last conflict set. -- -- This has two effects: -- -- - In a situation where there are no choices available at all (this happens --- if an unknown package is requested), the initial conflict set becomes the +-- if an unknown package is requested), the last conflict set becomes the -- actual conflict set. -- -- - In a situation where all of the children's conflict sets contain the @@ -165,7 +168,7 @@ -- avoidSet :: Var QPN -> QGoalReason -> ConflictSet avoidSet var gr = - CS.fromList (var : goalReasonToVars gr) + CS.union (CS.singleton var) (goalReasonToCS gr) -- | Interface. backjumpAndExplore :: EnableBackjumping diff --git a/Distribution/Solver/Modular/Flag.hs b/Distribution/Solver/Modular/Flag.hs --- a/Distribution/Solver/Modular/Flag.hs +++ b/Distribution/Solver/Modular/Flag.hs @@ -6,38 +6,43 @@ , FN(..) , QFN , QSN + , Stanza , SN(..) , WeakOrTrivial(..) + , FlagValue(..) , mkFlag - , showFBool , showQFN , showQFNBool + , showFlagValue , showQSN , showQSNBool + , showSBool ) where import Data.Map as M import Prelude hiding (pi) -import Distribution.PackageDescription hiding (Flag) -- from Cabal +import qualified Distribution.PackageDescription as P -- from Cabal -import Distribution.Solver.Modular.Package import Distribution.Solver.Types.Flag import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath -- | Flag name. Consists of a package instance and the flag identifier itself. -data FN qpn = FN (PI qpn) Flag +data FN qpn = FN qpn Flag deriving (Eq, Ord, Show, Functor) -- | Flag identifier. Just a string. -type Flag = FlagName +type Flag = P.FlagName +-- | Stanza identifier. +type Stanza = OptionalStanza + unFlag :: Flag -> String -unFlag = unFlagName +unFlag = P.unFlagName mkFlag :: String -> Flag -mkFlag = mkFlagName +mkFlag = P.mkFlagName -- | Flag info. Default value, whether the flag is manual, and -- whether the flag is weak. Manual flags can only be set explicitly. @@ -52,7 +57,7 @@ type QFN = FN QPN -- | Stanza name. Paired with a package name, much like a flag. -data SN qpn = SN (PI qpn) OptionalStanza +data SN qpn = SN qpn Stanza deriving (Eq, Ord, Show, Functor) -- | Qualified stanza name. @@ -72,21 +77,32 @@ newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } deriving (Eq, Ord, Show) +-- | Value shown for a flag in a solver log message. The message can refer to +-- only the true choice, only the false choice, or both choices. +data FlagValue = FlagTrue | FlagFalse | FlagBoth + deriving (Eq, Show) + showQFNBool :: QFN -> Bool -> String -showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b +showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b showQSNBool :: QSN -> Bool -> String -showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b +showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b showFBool :: FN qpn -> Bool -> String -showFBool (FN _ f) v = showFlagValue (f, v) +showFBool (FN _ f) v = P.showFlagValue (f, v) -showSBool :: SN qpn -> Bool -> String -showSBool (SN _ s) True = "*" ++ showStanza s -showSBool (SN _ s) False = "!" ++ showStanza s +-- | String representation of a flag-value pair. +showFlagValue :: P.FlagName -> FlagValue -> String +showFlagValue f FlagTrue = '+' : unFlag f +showFlagValue f FlagFalse = '-' : unFlag f +showFlagValue f FlagBoth = "+/-" ++ unFlag f +showSBool :: Stanza -> Bool -> String +showSBool s True = "*" ++ showStanza s +showSBool s False = "!" ++ showStanza s + showQFN :: QFN -> String -showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f +showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f showQSN :: QSN -> String -showQSN (SN pi s) = showPI pi ++ ":" ++ showStanza s +showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s diff --git a/Distribution/Solver/Modular/Index.hs b/Distribution/Solver/Modular/Index.hs --- a/Distribution/Solver/Modular/Index.hs +++ b/Distribution/Solver/Modular/Index.hs @@ -13,8 +13,7 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree - -import Distribution.Solver.Types.ComponentDeps (Component) +import Distribution.Types.UnqualComponentName -- | An index contains information about package instances. This is a nested -- dictionary. Package names are mapped to instances, which in turn is mapped @@ -22,13 +21,12 @@ type Index = Map PN (Map I PInfo) -- | Info associated with a package instance. --- Currently, dependencies, flags and failure reasons. +-- Currently, dependencies, executable names, flags and failure reasons. -- Packages that have a failure reason recorded for them are disabled -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason) - deriving (Show) +data PInfo = PInfo (FlaggedDeps PN) [UnqualComponentName] FlagInfo (Maybe FailReason) mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) @@ -42,9 +40,9 @@ | -- Find all versions of base .. Just is <- [M.lookup base idx] -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is + , (I _ver (Inst _), PInfo deps _exes _flagNfo _fr) <- M.toList is -- .. and flatten all their dependencies .. - , (Dep _is_exe dep _ci, _comp) <- flattenFlaggedDeps deps + , (LDep _ (Dep _is_exe dep _ci), _comp) <- flattenFlaggedDeps deps ] , qoSetupIndependent = True } diff --git a/Distribution/Solver/Modular/IndexConversion.hs b/Distribution/Solver/Modular/IndexConversion.hs --- a/Distribution/Solver/Modular/IndexConversion.hs +++ b/Distribution/Solver/Modular/IndexConversion.hs @@ -3,11 +3,11 @@ ) where import Data.List as L -import Data.Map as M +import Distribution.Compat.Map.Strict (Map) +import qualified Distribution.Compat.Map.Strict as M import Data.Maybe import Data.Monoid as Mon import Data.Set as S -import Prelude hiding (pi) import Distribution.Compiler import Distribution.InstalledPackageInfo as IPI @@ -55,8 +55,8 @@ -- explicitly requested. convPIs :: OS -> Arch -> CompilerInfo -> ShadowPkgs -> StrongFlags -> SolveExecutables -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index -convPIs os arch comp sip strfl sexes iidx sidx = - mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sexes sidx) +convPIs os arch comp sip strfl solveExes iidx sidx = + mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl solveExes sidx) -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. @@ -72,8 +72,8 @@ where -- shadowing is recorded in the package info - shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed)) - shadow x = x + shadow (pn, i, PInfo fdeps exes fds _) | sip = (pn, i, PInfo fdeps exes fds (Just Shadowed)) + shadow x = x -- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I. convId :: InstalledPackageInfo -> (PN, I) @@ -85,15 +85,14 @@ -- | Convert a single installed package into the solver-specific format. convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = - case mapM (convIPId pn idx) (IPI.depends ipi) of - Nothing -> (pn, i, PInfo [] M.empty (Just Broken)) - Just fds -> (pn, i, PInfo (setComp fds) M.empty Nothing) + case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of + Nothing -> (pn, i, PInfo [] [] M.empty (Just Broken)) + Just fds -> (pn, i, PInfo fds [] M.empty Nothing) where (pn, i) = convId ipi -- 'sourceLibName' is unreliable, but for now we only really use this for -- primary libs anyways - setComp = setCompFlaggedDeps $ componentNameToComponent - $ libraryComponentName $ sourceLibName ipi + comp = componentNameToComponent $ libraryComponentName $ sourceLibName ipi -- TODO: Installed packages should also store their encapsulations! -- Note [Index conversion with internal libraries] @@ -129,12 +128,12 @@ -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored. -convIPId :: PN -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep () PN) -convIPId pn' idx ipid = +convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Maybe (FlaggedDep PN) +convIPId dr comp idx ipid = case SI.lookupUnitId idx ipid of Nothing -> Nothing Just ipi -> let (pn, i) = convId ipi - in Just (D.Simple (Dep False pn (Fixed i (P pn'))) ()) + in Just (D.Simple (LDep dr (Dep Nothing pn (Fixed i))) comp) -- NB: something we pick up from the -- InstalledPackageIndex is NEVER an executable @@ -142,13 +141,13 @@ -- more uniform index format of the solver. convSPI' :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] -convSPI' os arch cinfo strfl sexes = L.map (convSP os arch cinfo strfl sexes) . CI.allPackages +convSPI' os arch cinfo strfl solveExes = L.map (convSP os arch cinfo strfl solveExes) . CI.allPackages -- | Convert a single source package into the solver-specific format. convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) -convSP os arch cinfo strfl sexes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = +convSP os arch cinfo strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo - in (pn, i, convGPD os arch cinfo strfl sexes (PI pn i) gpd) + in (pn, i, convGPD os arch cinfo strfl solveExes pn gpd) -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we @@ -156,8 +155,8 @@ -- | Convert a generic package description to a solver-specific 'PInfo'. convGPD :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> - PI PN -> GenericPackageDescription -> PInfo -convGPD os arch cinfo strfl sexes pi + PN -> GenericPackageDescription -> PInfo +convGPD os arch cinfo strfl solveExes pn (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) = let fds = flagInfo strfl flags @@ -171,22 +170,30 @@ ipns = S.fromList $ [ unqualComponentNameToPackageName nm | (nm, _) <- sub_libs ] - conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> - CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN - conv comp getInfo = convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes . - PDC.addBuildableCondition getInfo + conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN -> + CondTree ConfVar [Dependency] a -> FlaggedDeps PN + conv comp getInfo dr = + convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo ipns solveExes . + PDC.addBuildableCondition getInfo + initDR = DependencyReason pn M.empty S.empty + flagged_deps - = concatMap (\ds -> conv ComponentLib libBuildInfo ds) (maybeToList mlib) - ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo ds) sub_libs - ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo ds) flibs - ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo ds) exes - ++ prefix (Stanza (SN pi TestStanzas)) - (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo ds) tests) - ++ prefix (Stanza (SN pi BenchStanzas)) - (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs) - ++ maybe [] (convSetupBuildInfo pi) (setupBuildInfo pkg) + = concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib) + ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs + ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs + ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes + ++ prefix (Stanza (SN pn TestStanzas)) + (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds) + tests) + ++ prefix (Stanza (SN pn BenchStanzas)) + (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds) + benchs) + ++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg) + addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn + addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss) + -- | We infer the maximally supported spec-version from @lib:Cabal@'s version -- -- As we cannot predict the future, we can only properly support @@ -216,13 +223,13 @@ fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer) | otherwise = Nothing in - PInfo flagged_deps fds fr + PInfo flagged_deps (L.map fst exes) fds fr -- | Create a flagged dependency tree from a list @fds@ of flagged -- dependencies, using @f@ to form the tree node (@f@ will be -- something like @Stanza sn@). -prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) - -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn +prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) + -> [FlaggedDeps qpn] -> FlaggedDeps qpn prefix _ [] = [] prefix f fds = [f (concat fds)] @@ -239,43 +246,100 @@ -- dependencies. type IPNs = Set PN --- | Convenience function to delete a 'FlaggedDep' if it's +-- | Convenience function to delete a 'Dependency' if it's -- for a 'PN' that isn't actually real. -filterIPNs :: IPNs -> Dependency -> FlaggedDep Component PN -> FlaggedDeps Component PN -filterIPNs ipns (Dependency pn _) fd - | S.notMember pn ipns = [fd] - | otherwise = [] +filterIPNs :: IPNs -> Dependency -> Maybe Dependency +filterIPNs ipns d@(Dependency pn _) + | S.notMember pn ipns = Just d + | otherwise = Nothing -- | Convert condition trees to flagged dependencies. Mutually -- recursive with 'convBranch'. See 'convBranch' for an explanation -- of all arguments preceeding the input 'CondTree'. -convCondTree :: PackageDescription -> OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo -> +convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> Component -> (a -> BuildInfo) -> IPNs -> SolveExecutables -> - CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN -convCondTree pkg os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes@(SolveExecutables sexes') (CondNode info ds branches) = - concatMap - (\d -> filterIPNs ipns d (D.Simple (convLibDep pn d) comp)) - ds -- unconditional package dependencies - ++ L.map (\e -> D.Simple (Ext e) comp) (PD.allExtensions bi) -- unconditional extension dependencies - ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages bi) -- unconditional language dependencies - ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies - ++ concatMap (convBranch pkg os arch cinfo pi fds comp getInfo ipns sexes) branches + CondTree ConfVar [Dependency] a -> FlaggedDeps PN +convCondTree flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes@(SolveExecutables solveExes') (CondNode info ds branches) = + -- Merge all library and build-tool dependencies at every level in + -- the tree of flagged dependencies. Otherwise 'extractCommon' + -- could create duplicate dependencies, and the number of + -- duplicates could grow exponentially from the leaves to the root + -- of the tree. + mergeSimpleDeps $ + L.map (\d -> D.Simple (convLibDep dr d) comp) + (mapMaybe (filterIPNs ipns) ds) -- unconditional package dependencies + ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (PD.allExtensions bi) -- unconditional extension dependencies + ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (PD.allLanguages bi) -- unconditional language dependencies + ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies + ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes) branches -- build-tools dependencies -- NB: Only include these dependencies if SolveExecutables -- is True. It might be false in the legacy solver -- codepath, in which case there won't be any record of -- an executable we need. - ++ [ D.Simple (convExeDep pn exeDep) comp - | sexes' + ++ [ D.Simple (convExeDep dr exeDep) comp + | solveExes' , exeDep <- getAllToolDependencies pkg bi , not $ isInternal pkg exeDep ] where bi = getInfo info +data SimpleFlaggedDepKey qpn = + SimpleFlaggedDepKey (Maybe UnqualComponentName) qpn Component + deriving (Eq, Ord) + +data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR + +-- | Merge 'Simple' dependencies that apply to the same library or build-tool. +-- This function should be able to merge any two dependencies that can be merged +-- by extractCommon, in order to prevent the exponential growth of dependencies. +-- +-- Note that this function can merge dependencies that have different +-- DependencyReasons, which can make the DependencyReasons less precise. This +-- loss of precision only affects performance and log messages, not correctness. +-- However, when 'mergeSimpleDeps' is only called on dependencies at a single +-- location in the dependency tree, the only difference between +-- DependencyReasons should be flags that have value FlagBoth. Adding extra +-- flags with value FlagBoth should not affect performance, since they are not +-- added to the conflict set. The only downside is the possibility of the log +-- incorrectly saying that the flag contributed to excluding a specific version +-- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB +-- introduces pkg <5, the merged dependency would mean that +-- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply +-- that +/-flagA excludes pkg-6. +mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn +mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged + where + (merged, unmerged) = L.foldl' f (M.empty, []) deps + where + f :: Ord qpn + => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) + -> FlaggedDep qpn + -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) + f (merged', unmerged') (D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp) = + ( M.insertWith mergeValues + (SimpleFlaggedDepKey mExe qpn comp) + (SimpleFlaggedDepValue dr vr) + merged' + , unmerged') + f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged') + + mergeValues :: SimpleFlaggedDepValue qpn + -> SimpleFlaggedDepValue qpn + -> SimpleFlaggedDepValue qpn + mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) = + SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2) + + toFlaggedDep :: SimpleFlaggedDepKey qpn + -> SimpleFlaggedDepValue qpn + -> FlaggedDep qpn + toFlaggedDep (SimpleFlaggedDepKey mExe qpn comp) (SimpleFlaggedDepValue dr vr) = + D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp + -- | Branch interpreter. Mutually recursive with 'convCondTree'. -- -- Here, we try to simplify one of Cabal's condition tree branches into the @@ -287,46 +351,81 @@ -- -- This function takes a number of arguments: -- --- 1. Some pre dependency-solving known information ('OS', 'Arch', +-- 1. A map of flag values that have already been chosen. It allows +-- convBranch to avoid creating nested FlaggedDeps that are +-- controlled by the same flag and avoid creating DependencyReasons with +-- conflicting values for the same flag. +-- +-- 2. The DependencyReason calculated at this point in the tree of +-- conditionals. The flag values in the DependencyReason are similar to +-- the values in the map above, except for the use of FlagBoth. +-- +-- 3. Some pre dependency-solving known information ('OS', 'Arch', -- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables, -- --- 2. The package instance @'PI' 'PN'@ which this condition tree +-- 4. The package name @'PN'@ which this condition tree -- came from, so that we can correctly associate @flag()@ -- variables with the correct package name qualifier, -- --- 3. The flag defaults 'FlagInfo' so that we can populate +-- 5. The flag defaults 'FlagInfo' so that we can populate -- 'Flagged' dependencies with 'FInfo', -- --- 4. The name of the component 'Component' so we can record where +-- 6. The name of the component 'Component' so we can record where -- the fine-grained information about where the component came -- from (see 'convCondTree'), and -- --- 5. A selector to extract the 'BuildInfo' from the leaves of +-- 7. A selector to extract the 'BuildInfo' from the leaves of -- the 'CondTree' (which actually contains the needed -- dependency information.) -- --- 6. The set of package names which should be considered internal +-- 8. The set of package names which should be considered internal -- dependencies, and thus not handled as dependencies. -convBranch :: PackageDescription -> OS -> Arch -> CompilerInfo -> - PI PN -> FlagInfo -> - Component -> - (a -> BuildInfo) -> - IPNs -> - SolveExecutables -> - CondBranch ConfVar [Dependency] a -> - FlaggedDeps Component PN -convBranch pkg os arch cinfo pi@(PI pn _) fds comp getInfo ipns sexes (CondBranch c' t' mf') = - go c' ( convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes t') - (maybe [] (convCondTree pkg os arch cinfo pi fds comp getInfo ipns sexes) mf') +convBranch :: Map FlagName Bool + -> DependencyReason PN + -> PackageDescription + -> OS + -> Arch + -> CompilerInfo + -> PN + -> FlagInfo + -> Component + -> (a -> BuildInfo) + -> IPNs + -> SolveExecutables + -> CondBranch ConfVar [Dependency] a + -> FlaggedDeps PN +convBranch flags dr pkg os arch cinfo pn fds comp getInfo ipns solveExes (CondBranch c' t' mf') = + go c' + (\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes t') + (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo ipns solveExes) mf') + flags dr where - go :: Condition ConfVar -> - FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN + go :: Condition ConfVar + -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) + -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) + -> Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN go (Lit True) t _ = t go (Lit False) _ f = f go (CNot c) t f = go c f t go (CAnd c d) t f = go c (go d t f) f go (COr c d) t f = go c t (go d t f) - go (Var (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f] + go (Var (Flag fn)) t f = \flags' -> + case M.lookup fn flags' of + Just True -> t flags' + Just False -> f flags' + Nothing -> \dr' -> + -- Add each flag to the DependencyReason for all dependencies below, + -- including any extracted dependencies. Extracted dependencies are + -- introduced by both flag values (FlagBoth). Note that we don't + -- actually need to add the flag to the extracted dependencies for + -- correct backjumping; the information only improves log messages + -- by giving the user the full reason for each dependency. + let addFlagValue v = addFlagToDependencyReason fn v dr' + addFlag v = M.insert fn v flags' + in extractCommon (t (addFlag True) (addFlagValue FlagBoth)) + (f (addFlag False) (addFlagValue FlagBoth)) + ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True) (addFlagValue FlagTrue)) + (f (addFlag False) (addFlagValue FlagFalse)) ] go (Var (OS os')) t f | os == os' = t | otherwise = f @@ -344,36 +443,48 @@ where matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv + addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn + addFlagToDependencyReason fn v (DependencyReason pn' fs ss) = + DependencyReason pn' (M.insert fn v fs) ss + -- If both branches contain the same package as a simple dep, we lift it to - -- the next higher-level, but without constraints. This heuristic together - -- with deferring flag choices will then usually first resolve this package, - -- and try an already installed version before imposing a default flag choice - -- that might not be what we want. + -- the next higher-level, but with the union of version ranges. This + -- heuristic together with deferring flag choices will then usually first + -- resolve this package, and try an already installed version before imposing + -- a default flag choice that might not be what we want. -- -- Note that we make assumptions here on the form of the dependencies that - -- can occur at this point. In particular, no occurrences of Fixed, and no - -- occurrences of multiple version ranges, as all dependencies below this - -- point have been generated using 'convLibDep'. + -- can occur at this point. In particular, no occurrences of Fixed, as all + -- dependencies below this point have been generated using 'convLibDep'. -- -- WARNING: This is quadratic! - extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN - extractCommon ps ps' = [ D.Simple (Dep is_exe1 pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp - | D.Simple (Dep is_exe1 pn1 (Constrained [(vr1, _)])) _ <- ps - , D.Simple (Dep is_exe2 pn2 (Constrained [(vr2, _)])) _ <- ps' - , pn1 == pn2 - , is_exe1 == is_exe2 - ] + extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn + extractCommon ps ps' = + -- Union the DependencyReasons, because the extracted dependency can be + -- avoided by removing the dependency from either side of the + -- conditional. + [ D.Simple (LDep (unionDRs vs1 vs2) (Dep mExe1 pn1 (Constrained $ vr1 .||. vr2))) comp + | D.Simple (LDep vs1 (Dep mExe1 pn1 (Constrained vr1))) _ <- ps + , D.Simple (LDep vs2 (Dep mExe2 pn2 (Constrained vr2))) _ <- ps' + , pn1 == pn2 + , mExe1 == mExe2 + ] +-- | Merge DependencyReasons by unioning their variables. +unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn +unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = + DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) + -- | Convert a Cabal dependency on a library to a solver-specific dependency. -convLibDep :: PN -> Dependency -> Dep PN -convLibDep pn' (Dependency pn vr) = Dep False {- not exe -} pn (Constrained [(vr, P pn')]) +convLibDep :: DependencyReason PN -> Dependency -> LDep PN +convLibDep dr (Dependency pn vr) = LDep dr $ Dep Nothing pn (Constrained vr) --- | Convert a Cabal dependency on a executable (build-tools) to a solver-specific dependency. --- TODO do something about the name of the exe component itself -convExeDep :: PN -> ExeDependency -> Dep PN -convExeDep pn' (ExeDependency pn _ vr) = Dep True pn (Constrained [(vr, P pn')]) +-- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. +convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN +convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (Just exe) pn (Constrained vr) -- | Convert setup dependencies -convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN -convSetupBuildInfo (PI pn _i) nfo = - L.map (\d -> D.Simple (convLibDep pn d) ComponentSetup) (PD.setupDepends nfo) +convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN +convSetupBuildInfo pn nfo = + L.map (\d -> D.Simple (convLibDep (DependencyReason pn M.empty S.empty) d) ComponentSetup) + (PD.setupDepends nfo) diff --git a/Distribution/Solver/Modular/LabeledGraph.hs b/Distribution/Solver/Modular/LabeledGraph.hs --- a/Distribution/Solver/Modular/LabeledGraph.hs +++ b/Distribution/Solver/Modular/LabeledGraph.hs @@ -49,7 +49,7 @@ max_v = length edges0 - 1 bounds0 = (0, max_v) :: (Vertex, Vertex) sorted_edges = sortBy lt edges0 - edges1 = zipWith (,) [0..] sorted_edges + edges1 = zip [0..] sorted_edges graph = array bounds0 [(v, (mapMaybe mk_edge ks)) | (v, (_, _, ks)) <- edges1] diff --git a/Distribution/Solver/Modular/Linking.hs b/Distribution/Solver/Modular/Linking.hs --- a/Distribution/Solver/Modular/Linking.hs +++ b/Distribution/Solver/Modular/Linking.hs @@ -5,11 +5,12 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude hiding (get,put) +import Distribution.Solver.Compat.Prelude hiding (get,put) import Control.Exception (assert) import Control.Monad.Reader import Control.Monad.State +import Data.Function (on) import Data.Map ((!)) import Data.Set (Set) import qualified Data.Map as M @@ -28,7 +29,6 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.ComponentDeps (Component) import Distribution.Types.GenericPackageDescription (unFlagName) {------------------------------------------------------------------------------- @@ -59,8 +59,13 @@ , vsFlags :: FAssignment , vsStanzas :: SAssignment , vsQualifyOptions :: QualifyOptions + + -- Saved qualified dependencies. Every time 'validateLinking' makes a + -- package choice, it qualifies the package's dependencies and saves them in + -- this map. Then the qualified dependencies are available for subsequent + -- flag and stanza choices for the same package. + , vsSaved :: Map QPN (FlaggedDeps QPN) } - deriving Show type Validate = Reader ValidateState @@ -92,11 +97,12 @@ goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) goP qpn@(Q _pp pn) opt@(POption i _) r = do vs <- ask - let PInfo deps _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + let PInfo deps _ _ _ = vsIndex vs ! pn ! i + qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + newSaved = M.insert qpn qdeps (vsSaved vs) case execUpdateState (pickPOption qpn opt qdeps) vs of Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) - Right vs' -> local (const vs') r + Right vs' -> local (const vs' { vsSaved = newSaved }) r -- Flag choices goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) @@ -121,6 +127,7 @@ , vsFlags = M.empty , vsStanzas = M.empty , vsQualifyOptions = defaultQualifyOptions index + , vsSaved = M.empty } {------------------------------------------------------------------------------- @@ -149,7 +156,7 @@ execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState execUpdateState = execStateT . unUpdateState -pickPOption :: QPN -> POption -> FlaggedDeps Component QPN -> UpdateState () +pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState () pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps @@ -167,7 +174,7 @@ Just lg -> makeCanonical lg qpn i -pickLink :: QPN -> I -> PackagePath -> FlaggedDeps Component QPN -> UpdateState () +pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState () pickLink qpn@(Q _pp pn) i pp' deps = do vs <- get @@ -195,11 +202,11 @@ assert (sanityCheck (lgCanon lgTarget)) $ return () -- Merge the two link groups (updateLinkGroup will propagate the change) - lgTarget' <- lift' $ lgMerge [] lgSource lgTarget + lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget updateLinkGroup lgTarget' -- Make sure all dependencies are linked as well - linkDeps target [P qpn] deps + linkDeps target deps makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () makeCanonical lg qpn@(Q pp _) i = @@ -223,47 +230,47 @@ -- because having the direct dependencies in a link group means that we must -- have already made or will make sooner or later a link choice for one of these -- as well, and cover their dependencies at that point. -linkDeps :: QPN -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState () -linkDeps target = \blame deps -> do +linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState () +linkDeps target = \deps -> do -- linkDeps is called in two places: when we first link one package to -- another, and when we discover more dependencies of an already linked -- package after doing some flag assignment. It is therefore important that -- flag assignments cannot influence _how_ dependencies are qualified; -- fortunately this is a documented property of 'qualifyDeps'. rdeps <- requalify deps - go blame deps rdeps + go deps rdeps where - go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState () - go = zipWithM_ . go1 + go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState () + go = zipWithM_ go1 - go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState () - go1 blame dep rdep = case (dep, rdep) of - (Simple (Dep _ qpn _) _, ~(Simple (Dep _ qpn' _) _)) -> do + go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState () + go1 dep rdep = case (dep, rdep) of + (Simple (LDep dr1 (Dep _ qpn _)) _, ~(Simple (LDep dr2 (Dep _ qpn' _)) _)) -> do vs <- get let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs - lg'' <- lift' $ lgMerge blame lg lg' + lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToCS) dr1 dr2) lg lg' updateLinkGroup lg'' (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do vs <- get case M.lookup fn (vsFlags vs) of Nothing -> return () -- flag assignment not yet known - Just True -> go (F fn:blame) t t' - Just False -> go (F fn:blame) f f' + Just True -> go t t' + Just False -> go f f' (Stanza sn t, ~(Stanza _ t')) -> do vs <- get case M.lookup sn (vsStanzas vs) of Nothing -> return () -- stanza assignment not yet known - Just True -> go (S sn:blame) t t' + Just True -> go t t' Just False -> return () -- stanza not enabled; no new deps -- For extensions and language dependencies, there is nothing to do. -- No choice is involved, just checking, so there is nothing to link. -- The same goes for for pkg-config constraints. - (Simple (Ext _) _, _) -> return () - (Simple (Lang _) _, _) -> return () - (Simple (Pkg _ _) _, _) -> return () + (Simple (LDep _ (Ext _)) _, _) -> return () + (Simple (LDep _ (Lang _)) _, _) -> return () + (Simple (LDep _ (Pkg _ _)) _, _) -> return () - requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component QPN) + requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) requalify deps = do vs <- get return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) @@ -280,7 +287,7 @@ verifyStanza qsn linkNewDeps (S qsn) b --- | Link dependencies that we discover after making a flag choice. +-- | Link dependencies that we discover after making a flag or stanza choice. -- -- When we make a flag choice for a package, then new dependencies for that -- package might become available. If the package under consideration is in a @@ -290,31 +297,28 @@ linkNewDeps :: Var QPN -> Bool -> UpdateState () linkNewDeps var b = do vs <- get - let (qpn@(Q pp pn), Just i) = varPI var - PInfo deps _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + let qpn@(Q pp pn) = varPN var + qdeps = vsSaved vs ! qpn lg = vsLinks vs ! qpn - (parents, newDeps) = findNewDeps vs qdeps + newDeps = findNewDeps vs qdeps linkedTo = S.delete pp (lgMembers lg) - forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps + forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps where - findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN) - findNewDeps vs = concatMapUnzip (findNewDeps' vs) + findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN + findNewDeps vs = concatMap (findNewDeps' vs) - findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN) - findNewDeps' _ (Simple _ _) = ([], []) + findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN + findNewDeps' _ (Simple _ _) = [] findNewDeps' vs (Flagged qfn _ t f) = case (F qfn == var, M.lookup qfn (vsFlags vs)) of - (True, _) -> ([F qfn], if b then t else f) - (_, Nothing) -> ([], []) -- not yet known - (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f) - in (F qfn:parents, deps) + (True, _) -> if b then t else f + (_, Nothing) -> [] -- not yet known + (_, Just b') -> findNewDeps vs (if b' then t else f) findNewDeps' vs (Stanza qsn t) = case (S qsn == var, M.lookup qsn (vsStanzas vs)) of - (True, _) -> ([S qsn], if b then t else []) - (_, Nothing) -> ([], []) -- not yet known - (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else []) - in (S qsn:parents, deps) + (True, _) -> if b then t else [] + (_, Nothing) -> [] -- not yet known + (_, Just b') -> findNewDeps vs (if b' then t else []) updateLinkGroup :: LinkGroup -> UpdateState () updateLinkGroup lg = do @@ -342,27 +346,27 @@ -- if a constructor is added to the datatype we won't notice it here Just i -> do vs <- get - let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i + let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i flags = M.keys finfo stanzas = [TestStanzas, BenchStanzas] forM_ flags $ \fn -> do - let flag = FN (PI (lgPackage lg) i) fn + let flag = FN (lgPackage lg) fn verifyFlag' flag lg forM_ stanzas $ \sn -> do - let stanza = SN (PI (lgPackage lg) i) sn + let stanza = SN (lgPackage lg) sn verifyStanza' stanza lg verifyFlag :: QFN -> UpdateState () -verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do +verifyFlag (FN qpn@(Q _pp pn) fn) = do vs <- get -- We can only pick a flag after picking an instance; link group must exist - verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn) + verifyFlag' (FN pn fn) (vsLinks vs ! qpn) verifyStanza :: QSN -> UpdateState () -verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do +verifyStanza (SN qpn@(Q _pp pn) sn) = do vs <- get -- We can only pick a stanza after picking an instance; link group must exist - verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn) + verifyStanza' (SN pn sn) (vsLinks vs ! qpn) -- | Verify that all packages in the link group agree on flag assignments -- @@ -370,9 +374,9 @@ -- that have already been made for link group members, and check that they are -- equal. verifyFlag' :: FN PN -> LinkGroup -> UpdateState () -verifyFlag' (FN (PI pn i) fn) lg = do +verifyFlag' (FN pn fn) lg = do vs <- get - let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg)) + let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg)) vals = map (`M.lookup` vsFlags vs) flags if allEqual (catMaybes vals) -- We ignore not-yet assigned flags then return () @@ -388,9 +392,9 @@ -- -- This function closely mirrors 'verifyFlag''. verifyStanza' :: SN PN -> LinkGroup -> UpdateState () -verifyStanza' (SN (PI pn i) sn) lg = do +verifyStanza' (SN pn sn) lg = do vs <- get - let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg)) + let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg)) vals = map (`M.lookup` vsStanzas vs) stanzas if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas then return () @@ -472,14 +476,14 @@ , lgBlame = CS.empty } -lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup +lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup lgMerge blame lg lg' = do canon <- pick (lgCanon lg) (lgCanon lg') return LinkGroup { lgPackage = lgPackage lg , lgCanon = canon , lgMembers = lgMembers lg `S.union` lgMembers lg' - , lgBlame = CS.unions [CS.fromList blame, lgBlame lg, lgBlame lg'] + , lgBlame = CS.unions [blame, lgBlame lg, lgBlame lg'] } where pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) @@ -489,7 +493,7 @@ pick (Just x) (Just y) = if x == y then Right $ Just x else Left ( CS.unions [ - CS.fromList blame + blame , lgConflictSet lg , lgConflictSet lg' ] @@ -512,6 +516,3 @@ allEqual [] = True allEqual [_] = True allEqual (x:y:ys) = x == y && allEqual (y:ys) - -concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c]) -concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f diff --git a/Distribution/Solver/Modular/Log.hs b/Distribution/Solver/Modular/Log.hs --- a/Distribution/Solver/Modular/Log.hs +++ b/Distribution/Solver/Modular/Log.hs @@ -1,12 +1,11 @@ module Distribution.Solver.Modular.Log ( Log , logToProgress + , SolverFailure(..) ) where import Prelude () -import Distribution.Client.Compat.Prelude - -import Data.List as L +import Distribution.Solver.Compat.Prelude import Distribution.Solver.Types.Progress @@ -23,20 +22,22 @@ -- Parameterized over the type of actual messages and the final result. type Log m a = Progress m (ConflictSet, ConflictMap) a -messages :: Progress step fail done -> [step] -messages = foldProgress (:) (const []) (const []) +data Exhaustiveness = Exhaustive | BackjumpLimit -data Exhaustiveness = Exhaustive | BackjumpLimitReached +-- | Information about a dependency solver failure. It includes an error message +-- and a final conflict set, if available. +data SolverFailure = + NoSolution ConflictSet String + | BackjumpLimitReached String -- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. -- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the -- limit is 'Just 0', backtracking is completely disabled. -logToProgress :: Verbosity -> Maybe Int -> Log Message a -> Progress String String a +logToProgress :: Verbosity -> Maybe Int -> Log Message a -> Progress String SolverFailure a logToProgress verbosity mbj l = - let es = proc (Just 0) l -- catch first error (always) - ms = proc mbj l - in go es es -- trace for first error - (showMessages (const True) True ms) -- run with backjump limit applied + let ms = proc mbj l + mapFailure f = foldProgress Step (Fail . f) Done + in mapFailure finalError (showMessages ms) -- run with backjump limit applied where -- Proc takes the allowed number of backjumps and a 'Progress' and explores the -- messages until the maximum number of backjumps has been reached. It filters out @@ -48,30 +49,15 @@ proc _ (Fail (cs, cm)) = Fail (Exhaustive, cs, cm) proc mbj' (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _))) | cs == cs' = Step x (proc mbj' xs) -- repeated backjumps count as one - proc (Just 0) (Step (Failure cs Backjump) _) = Fail (BackjumpLimitReached, cs, mempty) -- No final conflict map available + proc (Just 0) (Step (Failure cs Backjump) _) = Fail (BackjumpLimit, cs, mempty) -- No final conflict map available proc (Just n) (Step x@(Failure _ Backjump) xs) = Step x (proc (Just (n - 1)) xs) proc mbj' (Step x xs) = Step x (proc mbj' xs) - -- The first two arguments are both supposed to be the log up to the first error. - -- That's the error that will always be printed in case we do not find a solution. - -- We pass this log twice, because we evaluate it in parallel with the full log, - -- but we also want to retain the reference to its beginning for when we print it. - -- This trick prevents a space leak! - -- - -- The third argument is the full log, ending with either the solution or the - -- exhaustiveness and final conflict set. - go :: Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b - -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b - -> Progress String (Exhaustiveness, ConflictSet, ConflictMap) b - -> Progress String String b - go ms (Step _ ns) (Step x xs) = Step x (go ms ns xs) - go ms r (Step x xs) = Step x (go ms r xs) - go ms (Step _ ns) r = go ms ns r - go ms (Fail (_, cs', _)) (Fail (exh, cs, cm)) = Fail $ - "Could not resolve dependencies:\n" ++ - unlines (messages $ showMessages (L.foldr (\ v _ -> v `CS.member` cs') True) False ms) ++ + finalError :: (Exhaustiveness, ConflictSet, ConflictMap) -> SolverFailure + finalError (exh, cs, cm) = case exh of Exhaustive -> + NoSolution cs $ "After searching the rest of the dependency tree exhaustively, " ++ "these were the goals I've had most trouble fulfilling: " ++ showCS cm cs @@ -79,14 +65,9 @@ showCS = if verbosity > normal then CS.showCSWithFrequency else CS.showCSSortedByFrequency - BackjumpLimitReached -> + BackjumpLimit -> + BackjumpLimitReached $ "Backjump limit reached (" ++ currlimit mbj ++ "change with --max-backjumps or try to run with --reorder-goals).\n" where currlimit (Just n) = "currently " ++ show n ++ ", " currlimit Nothing = "" - go _ _ (Done s) = Done s - go _ (Done _) (Fail _) = Fail $ - -- Should not happen: Second argument is the log up to first error, - -- third one is the entire log. Therefore it should never happen that - -- the second log finishes with 'Done' and the third log with 'Fail'. - "Could not resolve dependencies; something strange happened." diff --git a/Distribution/Solver/Modular/Message.hs b/Distribution/Solver/Modular/Message.hs --- a/Distribution/Solver/Modular/Message.hs +++ b/Distribution/Solver/Modular/Message.hs @@ -14,10 +14,12 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree - ( FailReason(..), POption(..) ) + ( FailReason(..), POption(..), ConflictingDep(..) ) +import Distribution.Solver.Modular.Version import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress +import Distribution.Types.UnqualComponentName data Message = Enter -- ^ increase indentation level @@ -31,59 +33,46 @@ -- | Transforms the structured message type to actual messages (strings). -- --- Takes an additional relevance predicate. The predicate gets a stack of goal --- variables and can decide whether messages regarding these goals are relevant. --- You can plug in 'const True' if you're interested in a full trace. If you --- want a slice of the trace concerning a particular conflict set, then plug in --- a predicate returning 'True' on the empty stack and if the head is in the --- conflict set. --- --- The second argument indicates if the level numbers should be shown. This is --- recommended for any trace that involves backtracking, because only the level --- numbers will allow to keep track of backjumps. -showMessages :: ([Var QPN] -> Bool) -> Bool -> Progress Message a b -> Progress String a b -showMessages p sl = go [] 0 +-- The log contains level numbers, which are useful for any trace that involves +-- backtracking, because only the level numbers will allow to keep track of +-- backjumps. +showMessages :: Progress Message a b -> Progress String a b +showMessages = go 0 where - -- The stack 'v' represents variables that are currently assigned by the - -- solver. 'go' pushes a variable for a recursive call when it encounters - -- 'TryP', 'TryF', or 'TryS' and pops a variable when it encounters 'Leave'. - -- When 'go' processes a package goal, or a package goal followed by a - -- 'Failure', it calls 'atLevel' with the goal variable at the head of the - -- stack so that the predicate can also select messages relating to package - -- goal choices. - go :: [Var QPN] -> Int -> Progress Message a b -> Progress String a b - go !_ !_ (Done x) = Done x - go !_ !_ (Fail x) = Fail x + -- 'go' increments the level for a recursive call when it encounters + -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'. + go :: Int -> Progress Message a b -> Progress String a b + go !_ (Done x) = Done x + go !_ (Fail x) = Fail x -- complex patterns - go !v !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - goPReject v l qpn [i] c fr ms - go !v !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) - go !v !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = - (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) - go !v !l (Step (Next (Goal (P qpn) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = - (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go (add (P qpn) v) l ms) - go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) = - (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms + go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + goPReject l qpn [i] c fr ms + go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms) + go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = + (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms) + go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = + (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms) + go !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) = + (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms -- the previous case potentially arises in the error output, because we remove the backjump itself -- if we cut the log after the first error - go !v !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) = - (atLevel (add (P qpn) v) l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go v l ms - go !v !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) = - let v' = add (P qpn) v - in (atLevel v' l $ showPackageGoal qpn gr) $ (atLevel v' l $ showFailure c fr) (go v l ms) - go !v !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _))) - | c == c' = go v l ms + go !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) = + (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms + go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) = + (atLevel l $ showPackageGoal qpn gr) $ (atLevel l $ showFailure c fr) (go l ms) + go !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _))) + | c == c' = go l ms -- standard display - go !v !l (Step Enter ms) = go v (l+1) ms - go !v !l (Step Leave ms) = go (drop 1 v) (l-1) ms - go !v !l (Step (TryP qpn i) ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms) - go !v !l (Step (TryF qfn b) ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms) - go !v !l (Step (TryS qsn b) ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms) - go !v !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel (add (P qpn) v) l $ showPackageGoal qpn gr) (go v l ms) - go !v !l (Step (Next _) ms) = go v l ms -- ignore flag goals in the log - go !v !l (Step (Success) ms) = (atLevel v l $ "done") (go v l ms) - go !v !l (Step (Failure c fr) ms) = (atLevel v l $ showFailure c fr) (go v l ms) + go !l (Step Enter ms) = go (l+1) ms + go !l (Step Leave ms) = go (l-1) ms + go !l (Step (TryP qpn i) ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms) + go !l (Step (TryF qfn b) ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms) + go !l (Step (TryS qsn b) ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms) + go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms) + go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log + go !l (Step (Success) ms) = (atLevel l $ "done") (go l ms) + go !l (Step (Failure c fr) ms) = (atLevel l $ showFailure c fr) (go l ms) showPackageGoal :: QPN -> QGoalReason -> String showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr @@ -91,30 +80,24 @@ showFailure :: ConflictSet -> FailReason -> String showFailure c fr = "fail" ++ showFR c fr - add :: Var QPN -> [Var QPN] -> [Var QPN] - add v vs = simplifyVar v : vs - -- special handler for many subsequent package rejections - goPReject :: [Var QPN] - -> Int + goPReject :: Int -> QPN -> [POption] -> ConflictSet -> FailReason -> Progress Message a b -> Progress String a b - goPReject v l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms)))) - | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms - goPReject v l qpn is c fr ms = - (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms) + goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms)))) + | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms + goPReject l qpn is c fr ms = + (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) - -- write a message, but only if it's relevant; we can also enable or disable the display of the current level - atLevel :: [Var QPN] -> Int -> String -> Progress String a b -> Progress String a b - atLevel v l x xs - | sl && p v = let s = show l - in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs - | p v = Step x xs - | otherwise = xs + -- write a message with the current level number + atLevel :: Int -> String -> Progress String a b -> Progress String a b + atLevel l x xs = + let s = show l + in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs showQPNPOpt :: QPN -> POption -> String showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = @@ -124,13 +107,16 @@ showGR :: QGoalReason -> String showGR UserGoal = " (user goal)" -showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")" -showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")" -showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")" +showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" showFR :: ConflictSet -> FailReason -> String -showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)" -showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")" +showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ display ext ++ ")" +showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ display lang ++ ")" +showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ display pn ++ display vr ++ ", not found in the pkg-config database)" +showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" +showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" +showFR _ (NewPackageIsMissingRequiredExe exe dr) = " (does not contain executable " ++ unUnqualComponentName exe ++ ", which is required by " ++ showDependencyReason dr ++ ")" +showFR _ (PackageRequiresMissingExe qpn exe) = " (requires executable " ++ unUnqualComponentName exe ++ " from " ++ showQPN qpn ++ ", but the executable does not exist)" showFR _ CannotInstall = " (only already installed instances can be used)" showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" showFR _ Shadowed = " (shadowed by another installed package with same version)" @@ -154,3 +140,15 @@ constraintSource :: ConstraintSource -> String constraintSource src = "constraint from " ++ showConstraintSource src + +showConflictingDep :: ConflictingDep -> String +showConflictingDep (ConflictingDep dr mExe qpn ci) = + let DependencyReason qpn' _ _ = dr + exeStr = case mExe of + Just exe -> " (exe " ++ unUnqualComponentName exe ++ ")" + Nothing -> "" + in case ci of + Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ + showQPN qpn ++ exeStr ++ "==" ++ showI i + Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ + exeStr ++ showVR vr diff --git a/Distribution/Solver/Modular/PSQ.hs b/Distribution/Solver/Modular/PSQ.hs --- a/Distribution/Solver/Modular/PSQ.hs +++ b/Distribution/Solver/Modular/PSQ.hs @@ -24,7 +24,6 @@ , snoc , sortBy , sortByKeys - , splits , toList , union ) where @@ -77,13 +76,6 @@ case xs of [] -> n (k, v) : ys -> c k v (PSQ ys) - -splits :: PSQ k a -> PSQ k (a, PSQ k a) -splits = go id - where - go f xs = casePSQ xs - (PSQ []) - (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys)) sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) diff --git a/Distribution/Solver/Modular/Package.hs b/Distribution/Solver/Modular/Package.hs --- a/Distribution/Solver/Modular/Package.hs +++ b/Distribution/Solver/Modular/Package.hs @@ -101,9 +101,7 @@ setupPP (PackagePath _ns (QualSetup _)) = True setupPP (PackagePath _ns _) = False --- | Create artificial parents for each of the package names, making --- them all independent. -makeIndependent :: [PN] -> [QPN] -makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..] - , let pp = PackagePath (Independent i) QualToplevel - ] +-- | Qualify a target package with its own name so that its dependencies are not +-- required to be consistent with other targets. +makeIndependent :: PN -> QPN +makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn diff --git a/Distribution/Solver/Modular/Preference.hs b/Distribution/Solver/Modular/Preference.hs --- a/Distribution/Solver/Modular/Preference.hs +++ b/Distribution/Solver/Modular/Preference.hs @@ -14,10 +14,11 @@ , preferReallyEasyGoalChoices , requireInstalled , sortGoals + , pruneAfterFirstSuccess ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Solver.Compat.Prelude import Data.Function (on) import qualified Data.List as L @@ -25,6 +26,8 @@ import Control.Monad.Reader hiding (sequence) import Data.Traversable (sequence) +import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal + import Distribution.Solver.Types.Flag import Distribution.Solver.Types.InstalledPreference import Distribution.Solver.Types.LabeledPackageConstraint @@ -128,7 +131,7 @@ preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c preferPackageStanzaPreferences pcs = trav go where - go (SChoiceF qsn@(SN (PI (Q pp pn) _) s) rdm gr _tr ts) + go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts) | primaryPP pp && enableStanzaPref pn s = -- move True case first to try enabling the stanza let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts @@ -187,7 +190,7 @@ where go :: PackageProperty -> Tree d c go (PackagePropertyFlags fa) = - case L.lookup f fa of + case lookupFlagAssignment f fa of Nothing -> r Just b | b == b' -> r | otherwise -> Fail c (GlobalConstraintFlag src) @@ -230,14 +233,14 @@ id (M.findWithDefault [] pn pcs) in PChoiceF qpn rdm gr (W.mapWithKey g ts) - go (FChoiceF qfn@(FN (PI qpn@(Q _ pn) _) f) rdm gr tr m d ts) = + go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) = let c = varToConflictSet (F qfn) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc) id (M.findWithDefault [] pn pcs) in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) - go (SChoiceF qsn@(SN (PI qpn@(Q _ pn) _) f) rdm gr tr ts) = + go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) = let c = varToConflictSet (S qsn) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc) @@ -260,23 +263,25 @@ -- unconstrained goals to use the default value for x OR any of the values in -- the constraints on x (even though the constraints don't apply), in order to -- allow the unconstrained goals to be linked to the constrained goals. See --- https://github.com/haskell/cabal/issues/4299. +-- https://github.com/haskell/cabal/issues/4299. Removing the single instance +-- restriction (SIR) would also fix #4299, so we may want to remove this +-- exception and only let the user toggle manual flags if we remove the SIR. -- -- This function does not enforce any of the constraints, since that is done by -- 'enforcePackageConstraints'. enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c enforceManualFlags pcs = trav go where - go (FChoiceF qfn@(FN (PI (Q _ pn) _) fn) rdm gr tr Manual d ts) = + go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) = FChoiceF qfn rdm gr tr Manual d $ - let -- A list of all values specified by constraints on 'fn', - -- regardless of scope. + let -- A list of all values specified by constraints on 'fn'. + -- We ignore the constraint scope in order to handle issue #4299. flagConstraintValues :: [Bool] flagConstraintValues = [ flagVal | let lpcs = M.findWithDefault [] pn pcs , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs - , (fn', flagVal) <- fa + , (fn', flagVal) <- unFlagAssignment fa , fn' == fn ] -- Prune flag values that are not the default and do not match any @@ -344,8 +349,19 @@ varToVariable :: Var QPN -> Variable QPN varToVariable (P qpn) = PackageVar qpn - varToVariable (F (FN (PI qpn _) fn)) = FlagVar qpn fn - varToVariable (S (SN (PI qpn _) stanza)) = StanzaVar qpn stanza + varToVariable (F (FN qpn fn)) = FlagVar qpn fn + varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza + +-- | Reduce the branching degree of the search tree by removing all choices +-- after the first successful choice at each level. The returned tree is the +-- minimal subtree containing the path to the first backjump. +pruneAfterFirstSuccess :: Tree d c -> Tree d c +pruneAfterFirstSuccess = trav go + where + go (PChoiceF qpn rdm gr ts) = PChoiceF qpn rdm gr (W.takeUntil active ts) + go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts) + go (SChoiceF qsn rdm gr w ts) = SChoiceF qsn rdm gr w (W.takeUntil active ts) + go x = x -- | Always choose the first goal in the list next, abandoning all -- other choices. diff --git a/Distribution/Solver/Modular/Solver.hs b/Distribution/Solver/Modular/Solver.hs --- a/Distribution/Solver/Modular/Solver.hs +++ b/Distribution/Solver/Modular/Solver.hs @@ -6,13 +6,13 @@ module Distribution.Solver.Modular.Solver ( SolverConfig(..) , solve + , PruneAfterFirstSuccess(..) ) where import Data.Map as M import Data.List as L import Data.Set as S import Distribution.Verbosity -import Distribution.Version import Distribution.Compiler (CompilerInfo) @@ -42,7 +42,6 @@ import Distribution.Simple.Setup (BooleanFlag(..)) #ifdef DEBUG_TRACETREE -import Distribution.Solver.Modular.Flag import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W import qualified Distribution.Text as T @@ -55,20 +54,25 @@ -- | Various options for the modular solver. data SolverConfig = SolverConfig { - reorderGoals :: ReorderGoals, - countConflicts :: CountConflicts, - independentGoals :: IndependentGoals, - avoidReinstalls :: AvoidReinstalls, - shadowPkgs :: ShadowPkgs, - strongFlags :: StrongFlags, - allowBootLibInstalls :: AllowBootLibInstalls, - maxBackjumps :: Maybe Int, - enableBackjumping :: EnableBackjumping, - solveExecutables :: SolveExecutables, - goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), - solverVerbosity :: Verbosity + reorderGoals :: ReorderGoals, + countConflicts :: CountConflicts, + independentGoals :: IndependentGoals, + avoidReinstalls :: AvoidReinstalls, + shadowPkgs :: ShadowPkgs, + strongFlags :: StrongFlags, + allowBootLibInstalls :: AllowBootLibInstalls, + maxBackjumps :: Maybe Int, + enableBackjumping :: EnableBackjumping, + solveExecutables :: SolveExecutables, + goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), + solverVerbosity :: Verbosity, + pruneAfterFirstSuccess :: PruneAfterFirstSuccess } +-- | Whether to remove all choices after the first successful choice at each +-- level in the search tree. +newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool + -- | Run all solver phases. -- -- In principle, we have a valid tree after 'validationPhase', which @@ -99,15 +103,18 @@ detectCycles = traceTree "cycles.json" id . detectCyclesPhase heuristicsPhase = let heuristicsTree = traceTree "heuristics.json" id - in case goalOrder sc of - Nothing -> goalChoiceHeuristics . - heuristicsTree . - P.deferSetupChoices . - P.deferWeakFlagChoices . - P.preferBaseGoalChoice - Just order -> P.firstGoal . - heuristicsTree . - P.sortGoals order + sortGoals = case goalOrder sc of + Nothing -> goalChoiceHeuristics . + heuristicsTree . + P.deferSetupChoices . + P.deferWeakFlagChoices . + P.preferBaseGoalChoice + Just order -> P.firstGoal . + heuristicsTree . + P.sortGoals order + PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc + in sortGoals . + (if prune then P.pruneAfterFirstSuccess else id) preferencesPhase = P.preferLinked . P.preferPackagePreferences userPrefs validationPhase = traceTree "validated.json" id . @@ -202,10 +209,8 @@ -- to know the variable that introduced the goal, not the value assigned -- to that variable) shortGR :: QGoalReason -> String - shortGR UserGoal = "user" - shortGR (PDependency (PI nm _)) = showQPN nm - shortGR (FDependency nm _) = showQFN nm - shortGR (SDependency nm) = showQSN nm + shortGR UserGoal = "user" + shortGR (DependencyGoal dr) = showDependencyReason dr -- Show conflict set goCS :: ConflictSet -> String @@ -232,6 +237,8 @@ . PSQ.toList dummy :: QGoalReason - dummy = PDependency - $ PI (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) - (I (mkVersion [1]) InRepo) + dummy = + DependencyGoal $ + DependencyReason + (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + M.empty S.empty diff --git a/Distribution/Solver/Modular/Tree.hs b/Distribution/Solver/Modular/Tree.hs --- a/Distribution/Solver/Modular/Tree.hs +++ b/Distribution/Solver/Modular/Tree.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Distribution.Solver.Modular.Tree - ( FailReason(..) - , POption(..) + ( POption(..) , Tree(..) , TreeF(..) , Weight + , FailReason(..) + , ConflictingDep(..) , ana , cata , inn @@ -12,6 +13,7 @@ , para , trav , zeroOrOneChoices + , active ) where import Control.Monad hiding (mapM, sequence) @@ -29,6 +31,8 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Flag import Distribution.Solver.Types.PackagePath +import Distribution.Types.UnqualComponentName +import Language.Haskell.Extension (Extension, Language) type Weight = Double @@ -72,7 +76,6 @@ -- | We failed to find a solution in this path through the tree | Fail ConflictSet FailReason - deriving (Eq, Show) -- | A package option is a package instance with an optional linking annotation -- @@ -93,8 +96,13 @@ data POption = POption I (Maybe PackagePath) deriving (Eq, Show) -data FailReason = InconsistentInitialConstraints - | Conflicting [Dep QPN] +data FailReason = UnsupportedExtension Extension + | UnsupportedLanguage Language + | MissingPkgconfigPackage PkgconfigName VR + | NewPackageDoesNotMatchExistingConstraint ConflictingDep + | ConflictingConstraints ConflictingDep ConflictingDep + | NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN) + | PackageRequiresMissingExe QPN UnqualComponentName | CannotInstall | CannotReinstall | Shadowed @@ -112,6 +120,10 @@ | DependenciesNotLinked String | CyclicDependencies | UnsupportedSpecVer Ver + deriving (Eq, Show) + +-- | Information about a dependency involved in a conflict, for error messages. +data ConflictingDep = ConflictingDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI deriving (Eq, Show) -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' diff --git a/Distribution/Solver/Modular/Validate.hs b/Distribution/Solver/Modular/Validate.hs --- a/Distribution/Solver/Modular/Validate.hs +++ b/Distribution/Solver/Modular/Validate.hs @@ -1,5 +1,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE CPP #-} +#ifdef DEBUG_CONFLICT_SETS +{-# LANGUAGE ImplicitParams #-} +#endif module Distribution.Solver.Modular.Validate (validateTree) where -- Validation of the tree. @@ -10,30 +14,35 @@ import Control.Applicative import Control.Monad.Reader hiding (sequence) +import Data.Function (on) import Data.List as L -import Data.Map as M import Data.Set as S import Data.Traversable import Prelude hiding (sequence) import Language.Haskell.Extension (Extension, Language) +import Distribution.Compat.Map.Strict as M import Distribution.Compiler (CompilerInfo(..)) import Distribution.Solver.Modular.Assignment +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree -import Distribution.Solver.Modular.Version (VR) +import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.WeightedPSQ as W -import Distribution.Solver.Types.ComponentDeps (Component) - import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) +import Distribution.Types.UnqualComponentName +#ifdef DEBUG_CONFLICT_SETS +import GHC.Stack (CallStack) +#endif + -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints -- that for which the preconditions are fulfilled ACTIVE. We maintain a set @@ -90,8 +99,23 @@ supportedLang :: Language -> Bool, presentPkgs :: PkgconfigName -> VR -> Bool, index :: Index, - saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies + + -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, + -- it qualifies the package's dependencies and saves them in this map. Then + -- the qualified dependencies are available for subsequent flag and stanza + -- choices for the same package. + saved :: Map QPN (FlaggedDeps QPN), + pa :: PreAssignment, + + -- Map from package name to the executables that are provided by the chosen + -- instance of that package. + availableExes :: Map QPN [UnqualComponentName], + + -- Map from package name to the executables that are required from that + -- package. + requiredExes :: Map QPN ExeDeps, + qualifyOptions :: QualifyOptions } @@ -101,6 +125,40 @@ runValidate :: Validate a -> ValidateState -> a runValidate (Validate r) = runReader r +-- | A preassignment comprises knowledge about variables, but not +-- necessarily fixed values. +data PreAssignment = PA PPreAssignment FAssignment SAssignment + +-- | A (partial) package preassignment. Qualified package names +-- are associated with MergedPkgDeps. +type PPreAssignment = Map QPN MergedPkgDep + +-- | A dependency on a package, including its DependencyReason. +data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI + +-- | Map from executable name to one of the reasons that the executable is +-- required. +type ExeDeps = Map UnqualComponentName (DependencyReason QPN) + +-- | MergedPkgDep records constraints about the instances that can still be +-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a +-- list of version ranges paired with the goals / variables that introduced +-- them. It also records whether a package is a build-tool dependency, for each +-- reason that it was introduced. +-- +-- It is important to store the executable name with the version constraint, for +-- error messages, because whether something is a build-tool dependency affects +-- its qualifier, which affects which constraint is applied. +data MergedPkgDep = + MergedDepFixed (Maybe UnqualComponentName) (DependencyReason QPN) I + | MergedDepConstrained [VROrigin] + +-- | Version ranges paired with origins. +type VROrigin = (VR, Maybe UnqualComponentName, DependencyReason QPN) + +-- | The information needed to create a 'Fail' node. +type Conflict = (ConflictSet, FailReason) + validate :: Tree d c -> Validate (Tree d c) validate = cata go where @@ -146,36 +204,51 @@ pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs idx <- asks index -- obtain the index svd <- asks saved -- obtain saved dependencies + aExes <- asks availableExes + rExes <- asks requiredExes qo <- asks qualifyOptions -- obtain dependencies and index-dictated exclusions introduced by the choice - let (PInfo deps _ mfr) = idx ! pn ! i + let (PInfo deps exes _ mfr) = idx ! pn ! i -- qualify the deps in the current scope let qdeps = qualifyDeps qo qpn deps -- the new active constraints are given by the instance we have chosen, -- plus the dependency information we have for that instance - -- TODO: is the False here right? - let newactives = Dep False {- not exe -} qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps) + let newactives = extractAllDeps pfa psa qdeps -- We now try to extend the partial assignment with the new active constraints. - let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives + let mnppa = extend extSupported langSupported pkgPresent newactives + =<< extendWithPackageChoice (PI qpn i) ppa -- In case we continue, we save the scoped dependencies let nsvd = M.insert qpn qdeps svd case mfr of Just fr -> -- The index marks this as an invalid choice. We can stop. return (Fail (varToConflictSet (P qpn)) fr) - _ -> case mnppa of - Left (c, d) -> -- We have an inconsistency. We can stop. - return (Fail c (Conflicting d)) - Right nppa -> -- We have an updated partial assignment for the recursive validation. - local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r + Nothing -> + let newDeps :: Either Conflict (PPreAssignment, Map QPN ExeDeps) + newDeps = do + nppa <- mnppa + rExes' <- extendRequiredExes aExes rExes newactives + checkExesInNewPackage rExes qpn exes + return (nppa, rExes') + in case newDeps of + Left (c, fr) -> -- We have an inconsistency. We can stop. + return (Fail c fr) + Right (nppa, rExes') -> -- We have an updated partial assignment for the recursive validation. + local (\ s -> s { pa = PA nppa pfa psa + , saved = nsvd + , availableExes = M.insert qpn exes aExes + , requiredExes = rExes' + }) r -- What to do for flag nodes ... goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goF qfn@(FN (PI qpn _i) _f) b r = do + goF qfn@(FN qpn _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies + svd <- asks saved -- obtain saved dependencies + aExes <- asks availableExes + rExes <- asks requiredExes -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. @@ -188,19 +261,24 @@ -- We now try to get the new active dependencies we might learn about because -- we have chosen a new flag. let newactives = extractNewDeps (F qfn) b npfa psa qdeps + mNewRequiredExes = extendRequiredExes aExes rExes newactives -- As in the package case, we try to extend the partial assignment. - case extend extSupported langSupported pkgPresent (F qfn) ppa newactives of - Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found - Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r + let mnppa = extend extSupported langSupported pkgPresent newactives ppa + case liftM2 (,) mnppa mNewRequiredExes of + Left (c, fr) -> return (Fail c fr) -- inconsistency found + Right (nppa, rExes') -> + local (\ s -> s { pa = PA nppa npfa psa, requiredExes = rExes' }) r -- What to do for stanza nodes (similar to flag nodes) ... goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goS qsn@(SN (PI qpn _i) _f) b r = do + goS qsn@(SN qpn _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs - svd <- asks saved -- obtain saved dependencies + svd <- asks saved -- obtain saved dependencies + aExes <- asks availableExes + rExes <- asks requiredExes -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. @@ -213,54 +291,197 @@ -- We now try to get the new active dependencies we might learn about because -- we have chosen a new flag. let newactives = extractNewDeps (S qsn) b pfa npsa qdeps + mNewRequiredExes = extendRequiredExes aExes rExes newactives -- As in the package case, we try to extend the partial assignment. - case extend extSupported langSupported pkgPresent (S qsn) ppa newactives of - Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found - Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r + let mnppa = extend extSupported langSupported pkgPresent newactives ppa + case liftM2 (,) mnppa mNewRequiredExes of + Left (c, fr) -> return (Fail c fr) -- inconsistency found + Right (nppa, rExes') -> + local (\ s -> s { pa = PA nppa pfa npsa, requiredExes = rExes' }) r +-- | Check that a newly chosen package instance contains all executables that +-- are required from that package so far. +checkExesInNewPackage :: Map QPN ExeDeps + -> QPN + -> [UnqualComponentName] + -> Either Conflict () +checkExesInNewPackage required qpn providedExes = + case M.toList $ deleteKeys providedExes (M.findWithDefault M.empty qpn required) of + (missingExe, dr) : _ -> let cs = CS.insert (P qpn) $ dependencyReasonToCS dr + in Left (cs, NewPackageIsMissingRequiredExe missingExe dr) + [] -> Right () + where + deleteKeys :: Ord k => [k] -> Map k v -> Map k v + deleteKeys ks m = L.foldr M.delete m ks + -- | We try to extract as many concrete dependencies from the given flagged -- dependencies as possible. We make use of all the flag knowledge we have -- already acquired. -extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] -extractDeps fa sa deps = do +extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractAllDeps fa sa deps = do d <- deps case d of Simple sd _ -> return sd Flagged qfn _ td fd -> case M.lookup qfn fa of Nothing -> mzero - Just True -> extractDeps fa sa td - Just False -> extractDeps fa sa fd + Just True -> extractAllDeps fa sa td + Just False -> extractAllDeps fa sa fd Stanza qsn td -> case M.lookup qsn sa of Nothing -> mzero - Just True -> extractDeps fa sa td + Just True -> extractAllDeps fa sa td Just False -> [] -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call --- 'extractDeps' for everything underneath. -extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN] +-- 'extractAllDeps' for everything underneath. +extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] extractNewDeps v b fa sa = go where - go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion) + go :: FlaggedDeps QPN -> [LDep QPN] go deps = do d <- deps case d of Simple _ _ -> mzero Flagged qfn' _ td fd - | v == F qfn' -> L.map (resetVar v) $ - if b then extractDeps fa sa td else extractDeps fa sa fd + | v == F qfn' -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd | otherwise -> case M.lookup qfn' fa of Nothing -> mzero Just True -> go td Just False -> go fd Stanza qsn' td - | v == S qsn' -> L.map (resetVar v) $ - if b then extractDeps fa sa td else [] + | v == S qsn' -> if b then extractAllDeps fa sa td else [] | otherwise -> case M.lookup qsn' sa of Nothing -> mzero Just True -> go td Just False -> [] +-- | Extend a package preassignment. +-- +-- Takes the variable that causes the new constraints, a current preassignment +-- and a set of new dependency constraints. +-- +-- We're trying to extend the preassignment with each dependency one by one. +-- Each dependency is for a particular variable. We check if we already have +-- constraints for that variable in the current preassignment. If so, we're +-- trying to merge the constraints. +-- +-- Either returns a witness of the conflict that would arise during the merge, +-- or the successfully extended assignment. +extend :: (Extension -> Bool) -- ^ is a given extension supported + -> (Language -> Bool) -- ^ is a given language supported + -> (PkgconfigName -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable + -> [LDep QPN] + -> PPreAssignment + -> Either Conflict PPreAssignment +extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives + where + + extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment + extendSingle a (LDep dr (Ext ext )) = + if extSupported ext then Right a + else Left (dependencyReasonToCS dr, UnsupportedExtension ext) + extendSingle a (LDep dr (Lang lang)) = + if langSupported lang then Right a + else Left (dependencyReasonToCS dr, UnsupportedLanguage lang) + extendSingle a (LDep dr (Pkg pn vr)) = + if pkgPresent pn vr then Right a + else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr) + extendSingle a (LDep dr (Dep mExe qpn ci)) = + let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a + in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr mExe qpn ci) of + Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') + Right x -> Right x + +-- | Extend a package preassignment with a package choice. For example, when +-- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. +extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment +extendWithPackageChoice (PI qpn i) ppa = + let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa + newChoice = PkgDep (DependencyReason qpn M.empty S.empty) Nothing qpn (Fixed i) + in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of + Left (c, (d, _d')) -> -- Don't include the package choice in the + -- FailReason, because it is redundant. + Left (c, NewPackageDoesNotMatchExistingConstraint d) + Right x -> Right x + +-- | Merge constrained instances. We currently adopt a lazy strategy for +-- merging, i.e., we only perform actual checking if one of the two choices +-- is fixed. If the merge fails, we return a conflict set indicating the +-- variables responsible for the failure, as well as the two conflicting +-- fragments. +-- +-- Note that while there may be more than one conflicting pair of version +-- ranges, we only return the first we find. +-- +-- The ConflictingDeps are returned in order, i.e., the first describes the +-- conflicting part of the MergedPkgDep, and the second describes the PkgDep. +-- +-- TODO: Different pairs might have different conflict sets. We're +-- obviously interested to return a conflict that has a "better" conflict +-- set in the sense the it contains variables that allow us to backjump +-- further. We might apply some heuristics here, such as to change the +-- order in which we check the constraints. +merge :: +#ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep +merge (MergedDepFixed mExe1 vs1 i1) (PkgDep vs2 mExe2 p ci@(Fixed i2)) + | i1 == i2 = Right $ MergedDepFixed mExe1 vs1 i1 + | otherwise = + Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + , ( ConflictingDep vs1 mExe1 p (Fixed i1) + , ConflictingDep vs2 mExe2 p ci ) ) + +merge (MergedDepFixed mExe1 vs1 i@(I v _)) (PkgDep vs2 mExe2 p ci@(Constrained vr)) + | checkVR vr v = Right $ MergedDepFixed mExe1 vs1 i + | otherwise = + Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + , ( ConflictingDep vs1 mExe1 p (Fixed i) + , ConflictingDep vs2 mExe2 p ci ) ) + +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) = + go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... + where + go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep + go [] = Right (MergedDepFixed mExe2 vs2 i) + go ((vr, mExe1, vs1) : vros) + | checkVR vr v = go vros + | otherwise = + Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + , ( ConflictingDep vs1 mExe1 p (Constrained vr) + , ConflictingDep vs2 mExe2 p ci ) ) + +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) = + Right (MergedDepConstrained $ + + -- TODO: This line appends the new version range, to preserve the order used + -- before a refactoring. Consider prepending the version range, if there is + -- no negative performance impact. + vrOrigins ++ [(vr, mExe2, vs2)]) + +-- | Takes a list of new dependencies and uses it to try to update the map of +-- known executable dependencies. It returns a failure when a new dependency +-- requires an executable that is missing from one of the previously chosen +-- packages. +extendRequiredExes :: Map QPN [UnqualComponentName] + -> Map QPN ExeDeps + -> [LDep QPN] + -> Either Conflict (Map QPN ExeDeps) +extendRequiredExes available = foldM extendSingle + where + extendSingle :: Map QPN ExeDeps -> LDep QPN -> Either Conflict (Map QPN ExeDeps) + extendSingle required (LDep dr (Dep (Just exe) qpn _)) = + let exeDeps = M.findWithDefault M.empty qpn required + in -- Only check for the existence of the exe if its package has already + -- been chosen. + case M.lookup qpn available of + Just exes + | L.notElem exe exes -> let cs = CS.insert (P qpn) (dependencyReasonToCS dr) + in Left (cs, PackageRequiresMissingExe qpn exe) + _ -> Right $ M.insertWith M.union qpn (M.insert exe dr exeDeps) required + extendSingle required _ = Right required + -- | Interface. validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { @@ -274,5 +495,7 @@ , index = idx , saved = M.empty , pa = PA M.empty M.empty M.empty + , availableExes = M.empty + , requiredExes = M.empty , qualifyOptions = defaultQualifyOptions idx } diff --git a/Distribution/Solver/Modular/Var.hs b/Distribution/Solver/Modular/Var.hs --- a/Distribution/Solver/Modular/Var.hs +++ b/Distribution/Solver/Modular/Var.hs @@ -1,15 +1,13 @@ {-# LANGUAGE DeriveFunctor #-} module Distribution.Solver.Modular.Var ( Var(..) - , simplifyVar , showVar - , varPI + , varPN ) where import Prelude hiding (pi) import Distribution.Solver.Modular.Flag -import Distribution.Solver.Modular.Package import Distribution.Solver.Types.PackagePath {------------------------------------------------------------------------------- @@ -24,23 +22,13 @@ data Var qpn = P qpn | F (FN qpn) | S (SN qpn) deriving (Eq, Ord, Show, Functor) --- | For computing conflict sets, we map flag choice vars to a --- single flag choice. This means that all flag choices are treated --- as interdependent. So if one flag of a package ends up in a --- conflict set, then all flags are being treated as being part of --- the conflict set. -simplifyVar :: Var qpn -> Var qpn -simplifyVar (P qpn) = P qpn -simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag")) -simplifyVar (S qsn) = S qsn - showVar :: Var QPN -> String showVar (P qpn) = showQPN qpn showVar (F qfn) = showQFN qfn showVar (S qsn) = showQSN qsn --- | Extract the package instance from a Var -varPI :: Var QPN -> (QPN, Maybe I) -varPI (P qpn) = (qpn, Nothing) -varPI (F (FN (PI qpn i) _)) = (qpn, Just i) -varPI (S (SN (PI qpn i) _)) = (qpn, Just i) +-- | Extract the package name from a Var +varPN :: Var qpn -> qpn +varPN (P qpn) = qpn +varPN (F (FN qpn _)) = qpn +varPN (S (SN qpn _)) = qpn diff --git a/Distribution/Solver/Modular/Version.hs b/Distribution/Solver/Modular/Version.hs --- a/Distribution/Solver/Modular/Version.hs +++ b/Distribution/Solver/Modular/Version.hs @@ -38,11 +38,11 @@ -- | Intersect two version ranges. (.&&.) :: VR -> VR -> VR -(.&&.) = CV.intersectVersionRanges +v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2 -- | Union of two version ranges. (.||.) :: VR -> VR -> VR -(.||.) = CV.unionVersionRanges +v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2 -- | Simplify a version range. simplifyVR :: VR -> VR diff --git a/Distribution/Solver/Modular/WeightedPSQ.hs b/Distribution/Solver/Modular/WeightedPSQ.hs --- a/Distribution/Solver/Modular/WeightedPSQ.hs +++ b/Distribution/Solver/Modular/WeightedPSQ.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.WeightedPSQ ( WeightedPSQ , fromList @@ -11,6 +12,7 @@ , mapWithKey , mapWeightsWithKey , union + , takeUntil ) where import qualified Data.Foldable as F @@ -75,6 +77,15 @@ -- second when they have the same weight. union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys) + +-- | /O(N)/. Return the prefix of values ending with the first element that +-- satisfies p, or all elements if none satisfy p. +takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v +takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs) + where + go :: [(w, k, v)] -> [(w, k, v)] + go [] = [] + go (y : ys) = y : if p (triple_3 y) then [] else go ys triple_1 :: (x, y, z) -> x triple_1 (x, _, _) = x diff --git a/Distribution/Solver/Types/ComponentDeps.hs b/Distribution/Solver/Types/ComponentDeps.hs --- a/Distribution/Solver/Types/ComponentDeps.hs +++ b/Distribution/Solver/Types/ComponentDeps.hs @@ -38,7 +38,7 @@ import Prelude () import Distribution.Types.UnqualComponentName -import Distribution.Client.Compat.Prelude hiding (empty,zip) +import Distribution.Solver.Compat.Prelude hiding (empty,zip) import qualified Data.Map as Map import Data.Foldable (fold) diff --git a/Distribution/Solver/Types/ConstraintSource.hs b/Distribution/Solver/Types/ConstraintSource.hs --- a/Distribution/Solver/Types/ConstraintSource.hs +++ b/Distribution/Solver/Types/ConstraintSource.hs @@ -49,6 +49,10 @@ -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a minimum lower bound on Cabal | ConstraintSetupCabalMinVersion + + -- | An internal constraint due to compatibility issues with the Setup.hs + -- command line interface requires a maximum upper bound on Cabal + | ConstraintSetupCabalMaxVersion deriving (Eq, Show, Generic) instance Binary ConstraintSource @@ -74,3 +78,5 @@ showConstraintSource ConstraintSourceUnknown = "unknown source" showConstraintSource ConstraintSetupCabalMinVersion = "minimum version of Cabal used by Setup.hs" +showConstraintSource ConstraintSetupCabalMaxVersion = + "maximum version of Cabal used by Setup.hs" diff --git a/Distribution/Solver/Types/PackageConstraint.hs b/Distribution/Solver/Types/PackageConstraint.hs --- a/Distribution/Solver/Types/PackageConstraint.hs +++ b/Distribution/Solver/Types/PackageConstraint.hs @@ -24,7 +24,7 @@ import Distribution.Types.Dependency (Dependency(..)) import Distribution.Version (VersionRange, simplifyVersionRange) -import Distribution.Client.Compat.Prelude ((<<>>)) +import Distribution.Solver.Compat.Prelude ((<<>>)) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath @@ -37,8 +37,18 @@ -- | Determines to what packages and in what contexts a -- constraint applies. data ConstraintScope + -- | A scope that applies when the given package is used as a build target. + -- In other words, the scope applies iff a goal has a top-level qualifier + -- and its namespace matches the given package name. A namespace is + -- considered to match a package name when it is either the default + -- namespace (for --no-independent-goals) or it is an independent namespace + -- with the given package name (for --independent-goals). + + -- TODO: Try to generalize the ConstraintScopes once component-based + -- solving is implemented, and remove this special case for targets. + = ScopeTarget PackageName -- | The package with the specified name and qualifier. - = ScopeQualified Qualifier PackageName + | ScopeQualified Qualifier PackageName -- | The package with the specified name when it has a -- setup qualifier. | ScopeAnySetupQualifier PackageName @@ -55,11 +65,16 @@ -- | Returns the package name associated with a constraint scope. scopeToPackageName :: ConstraintScope -> PackageName +scopeToPackageName (ScopeTarget pn) = pn scopeToPackageName (ScopeQualified _ pn) = pn scopeToPackageName (ScopeAnySetupQualifier pn) = pn scopeToPackageName (ScopeAnyQualifier pn) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool +constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = + let namespaceMatches DefaultNamespace = True + namespaceMatches (Independent namespacePn) = pn == namespacePn + in namespaceMatches ns && q == QualToplevel && pn == pn' constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = q == q' && pn == pn' constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = @@ -70,6 +85,7 @@ -- | Pretty-prints a constraint scope. dispConstraintScope :: ConstraintScope -> Disp.Doc +dispConstraintScope (ScopeTarget pn) = disp pn <<>> Disp.text "." <<>> disp pn dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> disp pn dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> disp pn dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> disp pn diff --git a/Distribution/Solver/Types/PackageIndex.hs b/Distribution/Solver/Types/PackageIndex.hs --- a/Distribution/Solver/Types/PackageIndex.hs +++ b/Distribution/Solver/Types/PackageIndex.hs @@ -46,7 +46,7 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude hiding (lookup) +import Distribution.Solver.Compat.Prelude hiding (lookup) import Control.Exception (assert) import qualified Data.Map as Map diff --git a/Distribution/Solver/Types/PackagePath.hs b/Distribution/Solver/Types/PackagePath.hs --- a/Distribution/Solver/Types/PackagePath.hs +++ b/Distribution/Solver/Types/PackagePath.hs @@ -12,7 +12,7 @@ import Distribution.Package import Distribution.Text import qualified Text.PrettyPrint as Disp -import Distribution.Client.Compat.Prelude ((<<>>)) +import Distribution.Solver.Compat.Prelude ((<<>>)) -- | A package path consists of a namespace and a package path inside that -- namespace. @@ -27,17 +27,15 @@ -- | The default namespace DefaultNamespace - -- | Independent namespace - -- - -- For now we just number these (rather than giving them more structure). - | Independent Int + -- | A namespace for a specific build target + | Independent PackageName deriving (Eq, Ord, Show) -- | Pretty-prints a namespace. The result is either empty or -- ends in a period, so it can be prepended onto a qualifier. dispNamespace :: Namespace -> Disp.Doc dispNamespace DefaultNamespace = Disp.empty -dispNamespace (Independent i) = Disp.int i <<>> Disp.text "." +dispNamespace (Independent i) = disp i <<>> Disp.text "." -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = diff --git a/Distribution/Solver/Types/PkgConfigDb.hs b/Distribution/Solver/Types/PkgConfigDb.hs --- a/Distribution/Solver/Types/PkgConfigDb.hs +++ b/Distribution/Solver/Types/PkgConfigDb.hs @@ -21,7 +21,7 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Solver.Compat.Prelude import Control.Exception (IOException, handle) import qualified Data.Map as M diff --git a/Distribution/Solver/Types/Progress.hs b/Distribution/Solver/Types/Progress.hs --- a/Distribution/Solver/Types/Progress.hs +++ b/Distribution/Solver/Types/Progress.hs @@ -4,7 +4,7 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude hiding (fail) +import Distribution.Solver.Compat.Prelude hiding (fail) -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final diff --git a/Distribution/Solver/Types/SolverPackage.hs b/Distribution/Solver/Types/SolverPackage.hs --- a/Distribution/Solver/Types/SolverPackage.hs +++ b/Distribution/Solver/Types/SolverPackage.hs @@ -20,8 +20,8 @@ -- but for symmetry we have the parameter. (Maybe it can be removed.) -- data SolverPackage loc = SolverPackage { - solverPkgSource :: SourcePackage loc, - solverPkgFlags :: FlagAssignment, + solverPkgSource :: SourcePackage loc, + solverPkgFlags :: FlagAssignment, solverPkgStanzas :: [OptionalStanza], solverPkgLibDeps :: ComponentDeps [SolverId], solverPkgExeDeps :: ComponentDeps [SolverId] diff --git a/Distribution/Solver/Types/Variable.hs b/Distribution/Solver/Types/Variable.hs --- a/Distribution/Solver/Types/Variable.hs +++ b/Distribution/Solver/Types/Variable.hs @@ -5,10 +5,9 @@ import Distribution.PackageDescription (FlagName) -- | Variables used by the dependency solver. This type is similar to the --- internal 'Var' type, except that flags and stanzas are associated with --- package names instead of package instances. +-- internal 'Var' type. data Variable qpn = PackageVar qpn | FlagVar qpn FlagName | StanzaVar qpn OptionalStanza - deriving Eq + deriving (Eq, Show) diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,1226 +0,0 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Main --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- Entry point to the default cabal-install front-end. ------------------------------------------------------------------------------ - -module Main (main) where - -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand, withRepoContext - , ConfigFlags(..) - , ConfigExFlags(..), defaultConfigExFlags, configureExCommand - , reconfigureCommand - , configCompilerAux', configPackageDB' - , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) - , buildCommand, replCommand, testCommand, benchmarkCommand - , InstallFlags(..), defaultInstallFlags - , installCommand, upgradeCommand, uninstallCommand - , FetchFlags(..), fetchCommand - , FreezeFlags(..), freezeCommand - , genBoundsCommand - , OutdatedFlags(..), outdatedCommand - , GetFlags(..), getCommand, unpackCommand - , checkCommand - , formatCommand - , updateCommand - , ListFlags(..), listCommand - , InfoFlags(..), infoCommand - , UploadFlags(..), uploadCommand - , ReportFlags(..), reportCommand - , runCommand - , InitFlags(initVerbosity), initCommand - , SDistFlags(..), SDistExFlags(..), sdistCommand - , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand - , ActAsSetupFlags(..), actAsSetupCommand - , SandboxFlags(..), sandboxCommand - , ExecFlags(..), execCommand - , UserConfigFlags(..), userConfigCommand - , reportCommand - , manpageCommand - ) -import Distribution.Simple.Setup - ( HaddockTarget(..) - , DoctestFlags(..), doctestCommand - , HaddockFlags(..), haddockCommand, defaultHaddockFlags - , HscolourFlags(..), hscolourCommand - , ReplFlags(..) - , CopyFlags(..), copyCommand - , RegisterFlags(..), registerCommand - , CleanFlags(..), cleanCommand - , TestFlags(..), BenchmarkFlags(..) - , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag - , configAbsolutePaths - ) - -import Prelude () -import Distribution.Client.Compat.Prelude hiding (get) - -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.Config - ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff - , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) -import Distribution.Client.Targets - ( readUserTargets ) -import qualified Distribution.Client.List as List - ( list, info ) - -import qualified Distribution.Client.CmdConfigure as CmdConfigure -import qualified Distribution.Client.CmdBuild as CmdBuild -import qualified Distribution.Client.CmdRepl as CmdRepl -import qualified Distribution.Client.CmdFreeze as CmdFreeze -import qualified Distribution.Client.CmdHaddock as CmdHaddock -import qualified Distribution.Client.CmdRun as CmdRun -import qualified Distribution.Client.CmdTest as CmdTest -import qualified Distribution.Client.CmdBench as CmdBench - -import Distribution.Client.Install (install) -import Distribution.Client.Configure (configure, writeConfigFlags) -import Distribution.Client.Update (update) -import Distribution.Client.Exec (exec) -import Distribution.Client.Fetch (fetch) -import Distribution.Client.Freeze (freeze) -import Distribution.Client.GenBounds (genBounds) -import Distribution.Client.Outdated (outdated) -import Distribution.Client.Check as Check (check) ---import Distribution.Client.Clean (clean) -import qualified Distribution.Client.Upload as Upload -import Distribution.Client.Run (run, splitRunArgs) -import Distribution.Client.SrcDist (sdist) -import Distribution.Client.Get (get) -import Distribution.Client.Reconfigure (Check(..), reconfigure) -import Distribution.Client.Nix (nixInstantiate - ,nixShell - ,nixShellIfSandboxed) -import Distribution.Client.Sandbox (sandboxInit - ,sandboxAddSource - ,sandboxDelete - ,sandboxDeleteSource - ,sandboxListSources - ,sandboxHcPkg - ,dumpPackageEnvironment - - ,loadConfigOrSandboxConfig - ,findSavedDistPref - ,initPackageDBIfNeeded - ,maybeWithSandboxDirOnSearchPath - ,maybeWithSandboxPackageInfo - ,tryGetIndexFilePath - ,sandboxBuildDir - ,updateSandboxConfigFileFlag - ,updateInstallDirs - - ,getPersistOrConfigCompiler) -import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB) -import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) -import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) -import Distribution.Client.Tar (createTarGzFile) -import Distribution.Client.Types (Password (..)) -import Distribution.Client.Init (initCabal) -import Distribution.Client.Manpage (manpage) -import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade -import Distribution.Client.Utils (determineNumJobs -#if defined(mingw32_HOST_OS) - ,relaxEncodingErrors -#endif - ) - -import Distribution.Package (packageId) -import Distribution.PackageDescription - ( BuildType(..), Executable(..), buildable ) -#ifdef CABAL_PARSEC -import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) -#else -import Distribution.PackageDescription.Parse ( readGenericPackageDescription ) -#endif - -import Distribution.PackageDescription.PrettyPrint - ( writeGenericPackageDescription ) -import qualified Distribution.Simple as Simple -import qualified Distribution.Make as Make -import qualified Distribution.Types.UnqualComponentName as Make -import Distribution.Simple.Build - ( startInterpreter ) -import Distribution.Simple.Command - ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) - , CommandType(..), commandsRun, commandAddAction, hiddenCommand - , commandFromSpec, commandShowOptions ) -import Distribution.Simple.Compiler (Compiler(..), PackageDBStack) -import Distribution.Simple.Configure - ( configCompilerAuxEx, ConfigStateFileError(..) - , getPersistBuildConfig, interpretPackageDbFlags - , tryGetPersistBuildConfig ) -import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Program (defaultProgramDb - ,configureAllKnownPrograms - ,simpleProgramInvocation - ,getProgramInvocationOutput) -import Distribution.Simple.Program.Db (reconfigurePrograms) -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Utils - ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler - , findPackageDesc, tryFindPackageDesc ) -import Distribution.Text - ( display ) -import Distribution.Verbosity as Verbosity - ( Verbosity, normal ) -import Distribution.Version - ( Version, mkVersion, orLaterVersion ) -import qualified Paths_cabal_install (version) - -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure, exitSuccess) -import System.FilePath ( dropExtension, splitExtension - , takeExtension, (), (<.>)) -import System.IO ( BufferMode(LineBuffering), hSetBuffering -#ifdef mingw32_HOST_OS - , stderr -#endif - , stdout ) -import System.Directory (doesFileExist, getCurrentDirectory) -import Data.Monoid (Any(..)) -import Control.Exception (SomeException(..), try) -import Control.Monad (mapM_) - -#ifdef MONOLITHIC -import qualified UnitTests -import qualified MemoryUsageTests -import qualified SolverQuickCheck -import qualified IntegrationTests2 -import qualified System.Environment as Monolithic -#endif - --- | Entry point --- -main :: IO () -#ifdef MONOLITHIC -main = do - mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE" - case mb_exec of - Just "UnitTests" -> UnitTests.main - Just "MemoryUsageTests" -> MemoryUsageTests.main - Just "SolverQuickCheck" -> SolverQuickCheck.main - Just "IntegrationTests2" -> IntegrationTests2.main - Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE" - Nothing -> main' -#else -main = main' -#endif - -main' :: IO () -main' = do - -- Enable line buffering so that we can get fast feedback even when piped. - -- This is especially important for CI and build systems. - hSetBuffering stdout LineBuffering - -- The default locale encoding for Windows CLI is not UTF-8 and printing - -- Unicode characters to it will fail unless we relax the handling of encoding - -- errors when writing to stderr and stdout. -#ifdef mingw32_HOST_OS - relaxEncodingErrors stdout - relaxEncodingErrors stderr -#endif - getArgs >>= mainWorker - -mainWorker :: [String] -> IO () -mainWorker args = topHandler $ - case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printGlobalHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (globalFlags, commandParse) -> - case commandParse of - _ | fromFlagOrDefault False (globalVersion globalFlags) - -> printVersion - | fromFlagOrDefault False (globalNumericVersion globalFlags) - -> printNumericVersion - CommandHelp help -> printCommandHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> do - globalFlags' <- updateSandboxConfigFileFlag globalFlags - action globalFlags' - - where - printCommandHelp help = do - pname <- getProgName - putStr (help pname) - printGlobalHelp help = do - pname <- getProgName - configFile <- defaultConfigFile - putStr (help pname) - putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" - ++ " " ++ configFile ++ "\n" - exists <- doesFileExist configFile - when (not exists) $ - putStrLn $ "This file will be generated with sensible " - ++ "defaults if you run 'cabal update'." - printOptionsList = putStr . unlines - printErrors errs = dieNoVerbosity $ intercalate "\n" errs - printNumericVersion = putStrLn $ display Paths_cabal_install.version - printVersion = putStrLn $ "cabal-install version " - ++ display Paths_cabal_install.version - ++ "\ncompiled using version " - ++ display cabalVersion - ++ " of the Cabal library " - - commands = map commandFromSpec commandSpecs - commandSpecs = - [ regularCmd installCommand installAction - , regularCmd updateCommand updateAction - , regularCmd listCommand listAction - , regularCmd infoCommand infoAction - , regularCmd fetchCommand fetchAction - , regularCmd freezeCommand freezeAction - , regularCmd getCommand getAction - , hiddenCmd unpackCommand unpackAction - , regularCmd checkCommand checkAction - , regularCmd sdistCommand sdistAction - , regularCmd uploadCommand uploadAction - , regularCmd reportCommand reportAction - , regularCmd runCommand runAction - , regularCmd initCommand initAction - , regularCmd configureExCommand configureAction - , regularCmd reconfigureCommand reconfigureAction - , regularCmd buildCommand buildAction - , regularCmd replCommand replAction - , regularCmd sandboxCommand sandboxAction - , regularCmd doctestCommand doctestAction - , regularCmd haddockCommand haddockAction - , regularCmd execCommand execAction - , regularCmd userConfigCommand userConfigAction - , regularCmd cleanCommand cleanAction - , regularCmd genBoundsCommand genBoundsAction - , regularCmd outdatedCommand outdatedAction - , wrapperCmd copyCommand copyVerbosity copyDistPref - , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref - , wrapperCmd registerCommand regVerbosity regDistPref - , regularCmd testCommand testAction - , regularCmd benchmarkCommand benchmarkAction - , hiddenCmd uninstallCommand uninstallAction - , hiddenCmd formatCommand formatAction - , hiddenCmd upgradeCommand upgradeAction - , hiddenCmd win32SelfUpgradeCommand win32SelfUpgradeAction - , hiddenCmd actAsSetupCommand actAsSetupAction - , hiddenCmd manpageCommand (manpageAction commandSpecs) - - , regularCmd CmdConfigure.configureCommand CmdConfigure.configureAction - , regularCmd CmdBuild.buildCommand CmdBuild.buildAction - , regularCmd CmdRepl.replCommand CmdRepl.replAction - , regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction - , regularCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction - , regularCmd CmdRun.runCommand CmdRun.runAction - , regularCmd CmdTest.testCommand CmdTest.testAction - , regularCmd CmdBench.benchCommand CmdBench.benchAction - ] - -type Action = GlobalFlags -> IO () - -regularCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action -regularCmd ui action = - CommandSpec ui ((flip commandAddAction) action) NormalCommand - -hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) - -> CommandSpec action -hiddenCmd ui action = - CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) - HiddenCommand - -wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) - -> (flags -> Flag String) -> CommandSpec Action -wrapperCmd ui verbosity distPref = - CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand - -wrapperAction :: Monoid flags - => CommandUI flags - -> (flags -> Flag Verbosity) - -> (flags -> Flag String) - -> Command Action -wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command - { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do - let verbosity = fromFlagOrDefault normal (verbosityFlag flags) - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (distPrefFlag flags) - let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - command (const flags) extraArgs - -configureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> Action -configureAction (configFlags, configExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) - <$> loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (configDistPref configFlags) - nixInstantiate verbosity distPref True globalFlags config - nixShell verbosity distPref globalFlags config $ do - let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = savedConfigureExFlags config `mappend` configExFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAuxEx configFlags' - - -- If we're working inside a sandbox and the user has set the -w option, we - -- may need to create a sandbox-local package DB for this compiler and add a - -- timestamp record for this compiler to the timestamp file. - let configFlags'' = case useSandbox of - NoSandbox -> configFlags' - (UseSandbox sandboxDir) -> setPackageDB sandboxDir - comp platform configFlags' - - writeConfigFlags verbosity distPref (configFlags'', configExFlags') - - -- What package database(s) to use - let packageDBs :: PackageDBStack - packageDBs - = interpretPackageDbFlags - (fromFlag (configUserInstall configFlags'')) - (configPackageDBs configFlags'') - - whenUsingSandbox useSandbox $ \sandboxDir -> do - initPackageDBIfNeeded verbosity configFlags'' comp progdb - -- NOTE: We do not write the new sandbox package DB location to - -- 'cabal.sandbox.config' here because 'configure -w' must not affect - -- subsequent 'install' (for UI compatibility with non-sandboxed mode). - - indexFile <- tryGetIndexFilePath verbosity config - maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile - (compilerId comp) platform - - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - configure verbosity packageDBs repoContext - comp platform progdb configFlags'' configExFlags' extraArgs - -reconfigureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> Action -reconfigureAction flags@(configFlags, _) _ globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) - <$> loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (configDistPref configFlags) - let checkFlags = Check $ \_ saved -> do - let flags' = saved <> flags - unless (saved == flags') $ info verbosity message - pure (Any True, flags') - where - -- This message is correct, but not very specific: it will list all - -- of the new flags, even if some have not actually changed. The - -- *minimal* set of changes is more difficult to determine. - message = - "flags changed: " - ++ unwords (commandShowOptions configureExCommand flags) - nixInstantiate verbosity distPref True globalFlags config - _ <- - reconfigure configureAction - verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag - checkFlags [] globalFlags config - pure () - -buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action -buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (buildDistPref buildFlags) - -- Calls 'configureAction' to do the real work, so nothing special has to be - -- done to support sandboxes. - config' <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) - mempty [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config' distPref buildFlags extraArgs - - --- | Actually do the work of building the package. This is separate from --- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke --- 'reconfigure' twice. -build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () -build verbosity config distPref buildFlags extraArgs = - setupWrapper verbosity setupOptions Nothing - (Cabal.buildCommand progDb) mkBuildFlags extraArgs - where - progDb = defaultProgramDb - setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - - mkBuildFlags version = filterBuildFlags version config buildFlags' - buildFlags' = buildFlags - { buildVerbosity = toFlag verbosity - , buildDistPref = toFlag distPref - } - --- | Make sure that we don't pass new flags to setup scripts compiled against --- old versions of Cabal. -filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags -filterBuildFlags version config buildFlags - | version >= mkVersion [1,19,1] = buildFlags_latest - -- Cabal < 1.19.1 doesn't support 'build -j'. - | otherwise = buildFlags_pre_1_19_1 - where - buildFlags_pre_1_19_1 = buildFlags { - buildNumJobs = NoFlag - } - buildFlags_latest = buildFlags { - -- Take the 'jobs' setting '~/.cabal/config' into account. - buildNumJobs = Flag . Just . determineNumJobs $ - (numJobsConfigFlag `mappend` numJobsCmdLineFlag) - } - numJobsConfigFlag = installNumJobs . savedInstallFlags $ config - numJobsCmdLineFlag = buildNumJobs buildFlags - - -replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action -replAction (replFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (replDistPref replFlags) - cwd <- getCurrentDirectory - pkgDesc <- findPackageDesc cwd - let - -- There is a .cabal file in the current directory: start a REPL and load - -- the project's modules. - onPkgDesc = do - let noAddSource = case replReload replFlags of - Flag True -> SkipAddSourceDepsCheck - _ -> fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - - -- Calls 'configureAction' to do the real work, so nothing special has to - -- be done to support sandboxes. - _ <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource NoFlag - mempty [] globalFlags config - let progDb = defaultProgramDb - setupOptions = defaultSetupScriptOptions - { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] - , useDistPref = distPref - } - replFlags' = replFlags - { replVerbosity = toFlag verbosity - , replDistPref = toFlag distPref - } - - nixShell verbosity distPref globalFlags config $ do - maybeWithSandboxDirOnSearchPath useSandbox $ - setupWrapper verbosity setupOptions Nothing - (Cabal.replCommand progDb) (const replFlags') extraArgs - - -- No .cabal file in the current directory: just start the REPL (possibly - -- using the sandbox package DB). - onNoPkgDesc = do - let configFlags = savedConfigureFlags config - (comp, platform, programDb) <- configCompilerAux' configFlags - programDb' <- reconfigurePrograms verbosity - (replProgramPaths replFlags) - (replProgramArgs replFlags) - programDb - nixShell verbosity distPref globalFlags config $ do - startInterpreter verbosity programDb' comp platform - (configPackageDB' configFlags) - - either (const onNoPkgDesc) (const onPkgDesc) pkgDesc - -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) - -> [String] -> Action -installAction (configFlags, _, installFlags, _) _ globalFlags - | fromFlagOrDefault False (installOnly installFlags) = do - let verb = fromFlagOrDefault normal (configVerbosity configFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags - dist <- findSavedDistPref config (configDistPref configFlags) - let setupOpts = defaultSetupScriptOptions { useDistPref = dist } - nixShellIfSandboxed verb dist globalFlags config useSandbox $ - setupWrapper - verb setupOpts Nothing - installCommand (const mempty) [] - -installAction - (configFlags, configExFlags, installFlags, haddockFlags) - extraArgs globalFlags = do - let verb = fromFlagOrDefault normal (configVerbosity configFlags) - (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) - <$> loadConfigOrSandboxConfig verb globalFlags - - let sandboxDist = - case useSandbox of - NoSandbox -> NoFlag - UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir - dist <- findSavedDistPref config - (configDistPref configFlags `mappend` sandboxDist) - - nixShellIfSandboxed verb dist globalFlags config useSandbox $ do - targets <- readUserTargets verb extraArgs - - -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to - -- 'configure' when run inside a sandbox. Right now, running - -- - -- $ cabal sandbox init && cabal configure -w /path/to/ghc - -- && cabal build && cabal install - -- - -- performs the compilation twice unless you also pass -w to 'install'. - -- However, this is the same behaviour that 'cabal install' has in the normal - -- mode of operation, so we stick to it for consistency. - - let configFlags' = maybeForceTests installFlags' $ - savedConfigureFlags config `mappend` - configFlags { configDistPref = toFlag dist } - configExFlags' = defaultConfigExFlags `mappend` - savedConfigureExFlags config `mappend` configExFlags - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config `mappend` installFlags - haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config `mappend` - haddockFlags { haddockDistPref = toFlag dist } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags' - -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the - -- future. - progdb' <- configureAllKnownPrograms verb progdb - - -- If we're working inside a sandbox and the user has set the -w option, we - -- may need to create a sandbox-local package DB for this compiler and add a - -- timestamp record for this compiler to the timestamp file. - configFlags'' <- case useSandbox of - NoSandbox -> configAbsolutePaths $ configFlags' - (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform - configFlags' - - whenUsingSandbox useSandbox $ \sandboxDir -> do - initPackageDBIfNeeded verb configFlags'' comp progdb' - - indexFile <- tryGetIndexFilePath verb config - maybeAddCompilerTimestampRecord verb sandboxDir indexFile - (compilerId comp) platform - - -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means - -- that 'cabal install some-package' inside a sandbox will sometimes reinstall - -- modified add-source deps, even if they are not among the dependencies of - -- 'some-package'. This can also prevent packages that depend on older - -- versions of add-source'd packages from building (see #1362). - maybeWithSandboxPackageInfo verb configFlags'' globalFlags' - comp platform progdb useSandbox $ \mSandboxPkgInfo -> - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verb globalFlags' $ \repoContext -> - install verb - (configPackageDB' configFlags'') - repoContext - comp platform progdb' - useSandbox mSandboxPkgInfo - globalFlags' configFlags'' configExFlags' - installFlags' haddockFlags' - targets - - where - -- '--run-tests' implies '--enable-tests'. - maybeForceTests installFlags' configFlags' = - if fromFlagOrDefault False (installRunTests installFlags') - then configFlags' { configTests = toFlag True } - else configFlags' - -testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags - -> IO () -testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (testDistPref testFlags) - let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - buildFlags' = buildFlags - { buildVerbosity = testVerbosity testFlags } - checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> - if fromFlagOrDefault False (configTests configFlags) - then pure (mempty, flags) - else do - info verbosity "reconfiguring to enable tests" - let flags' = ( configFlags { configTests = toFlag True } - , configExFlags - ) - pure (Any True, flags') - - -- reconfigure also checks if we're in a sandbox and reinstalls add-source - -- deps if needed. - _ <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') - checkFlags [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - testFlags' = testFlags { testDistPref = toFlag distPref } - - -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "test suites" - (\c -> case c of { LBI.CTest{} -> True; _ -> False }) - let extraArgs' - | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [ Make.unUnqualComponentName name - | LBI.CTestName name <- names' ] - | otherwise = extraArgs - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config distPref buildFlags' extraArgs' - - maybeWithSandboxDirOnSearchPath useSandbox $ - setupWrapper verbosity setupOptions Nothing - Cabal.testCommand (const testFlags') extraArgs' - -data ComponentNames = ComponentNamesUnknown - | ComponentNames [LBI.ComponentName] - --- | Return the names of all buildable components matching a given predicate. -componentNamesFromLBI :: Verbosity -> FilePath -> String - -> (LBI.Component -> Bool) - -> IO ComponentNames -componentNamesFromLBI verbosity distPref targetsDescr compPred = do - eLBI <- tryGetPersistBuildConfig distPref - case eLBI of - Left err -> case err of - -- Note: the build config could have been generated by a custom setup - -- script built against a different Cabal version, so it's crucial that - -- we ignore the bad version error here. - ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown - _ -> die' verbosity (show err) - Right lbi -> do - let pkgDescr = LBI.localPkgDescr lbi - names = map LBI.componentName - . filter (buildable . LBI.componentBuildInfo) - . filter compPred $ - LBI.pkgComponents pkgDescr - if null names - then do notice verbosity $ "Package has no buildable " - ++ targetsDescr ++ "." - exitSuccess -- See #3215. - - else return $! (ComponentNames names) - -benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags) - -> [String] -> GlobalFlags - -> IO () -benchmarkAction - (benchmarkFlags, buildFlags, buildExFlags) - extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal - (benchmarkVerbosity benchmarkFlags) - - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) - let buildFlags' = buildFlags - { buildVerbosity = benchmarkVerbosity benchmarkFlags } - noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - - let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> - if fromFlagOrDefault False (configBenchmarks configFlags) - then pure (mempty, flags) - else do - info verbosity "reconfiguring to enable benchmarks" - let flags' = ( configFlags { configBenchmarks = toFlag True } - , configExFlags - ) - pure (Any True, flags') - - - -- reconfigure also checks if we're in a sandbox and reinstalls add-source - -- deps if needed. - config' <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') - checkFlags [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } - benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } - - -- The package was just configured, so the LBI must be available. - names <- componentNamesFromLBI verbosity distPref "benchmarks" - (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) - let extraArgs' - | null extraArgs = case names of - ComponentNamesUnknown -> [] - ComponentNames names' -> [ Make.unUnqualComponentName name - | LBI.CBenchName name <- names'] - | otherwise = extraArgs - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config' distPref buildFlags' extraArgs' - - maybeWithSandboxDirOnSearchPath useSandbox $ - setupWrapper verbosity setupOptions Nothing - Cabal.benchmarkCommand (const benchmarkFlags') extraArgs' - -haddockAction :: HaddockFlags -> [String] -> Action -haddockAction haddockFlags extraArgs globalFlags = do - let verbosity = fromFlag (haddockVerbosity haddockFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (haddockDistPref haddockFlags) - config' <- - reconfigure configureAction - verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag - mempty [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - let haddockFlags' = defaultHaddockFlags `mappend` - savedHaddockFlags config' `mappend` - haddockFlags { haddockDistPref = toFlag distPref } - setupScriptOptions = defaultSetupScriptOptions - { useDistPref = distPref } - setupWrapper verbosity setupScriptOptions Nothing - haddockCommand (const haddockFlags') extraArgs - when (haddockForHackage haddockFlags == Flag ForHackage) $ do - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - let dest = distPref name <.> "tar.gz" - name = display (packageId pkg) ++ "-docs" - docDir = distPref "doc" "html" - createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - -doctestAction :: DoctestFlags -> [String] -> Action -doctestAction doctestFlags extraArgs _globalFlags = do - let verbosity = fromFlag (doctestVerbosity doctestFlags) - - setupWrapper verbosity defaultSetupScriptOptions Nothing - doctestCommand (const doctestFlags) extraArgs - -cleanAction :: CleanFlags -> [String] -> Action -cleanAction cleanFlags extraArgs globalFlags = do - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (cleanDistPref cleanFlags) - let setupScriptOptions = defaultSetupScriptOptions - { useDistPref = distPref - , useWin32CleanHack = True - } - cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } - setupWrapper verbosity setupScriptOptions Nothing - cleanCommand (const cleanFlags') extraArgs - where - verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) - -listAction :: ListFlags -> [String] -> Action -listAction listFlags extraArgs globalFlags = do - let verbosity = fromFlag (listVerbosity listFlags) - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let configFlags' = savedConfigureFlags config - configFlags = configFlags' { - configPackageDBs = configPackageDBs configFlags' - `mappend` listPackageDBs listFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - List.list verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - listFlags - extraArgs - -infoAction :: InfoFlags -> [String] -> Action -infoAction infoFlags extraArgs globalFlags = do - let verbosity = fromFlag (infoVerbosity infoFlags) - targets <- readUserTargets verbosity extraArgs - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let configFlags' = savedConfigureFlags config - configFlags = configFlags' { - configPackageDBs = configPackageDBs configFlags' - `mappend` infoPackageDBs infoFlags - } - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAuxEx configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - List.info verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - globalFlags' - infoFlags - targets - -updateAction :: Flag Verbosity -> [String] -> Action -updateAction verbosityFlag extraArgs globalFlags = do - let verbosity = fromFlag verbosityFlag - unless (null extraArgs) $ - die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - update verbosity repoContext - -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) - -> [String] -> Action -upgradeAction (configFlags, _, _, _) _ _ = die' verbosity $ - "Use the 'cabal install' command instead of 'cabal upgrade'.\n" - ++ "You can install the latest version of a package using 'cabal install'. " - ++ "The 'cabal upgrade' command has been removed because people found it " - ++ "confusing and it often led to broken packages.\n" - ++ "If you want the old upgrade behaviour then use the install command " - ++ "with the --upgrade-dependencies flag (but check first with --dry-run " - ++ "to see what would happen). This will try to pick the latest versions " - ++ "of all dependencies, rather than the usual behaviour of trying to pick " - ++ "installed versions of all dependencies. If you do use " - ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " - ++ "packages (e.g. by using appropriate --constraint= flags)." - where - verbosity = fromFlag (configVerbosity configFlags) - -fetchAction :: FetchFlags -> [String] -> Action -fetchAction fetchFlags extraArgs globalFlags = do - let verbosity = fromFlag (fetchVerbosity fetchFlags) - targets <- readUserTargets verbosity extraArgs - config <- loadConfig verbosity (globalConfigFile globalFlags) - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - fetch verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb globalFlags' fetchFlags - targets - -freezeAction :: FreezeFlags -> [String] -> Action -freezeAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config NoFlag - nixShell verbosity distPref globalFlags config $ do - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags - - maybeWithSandboxPackageInfo - verbosity configFlags globalFlags' - comp platform progdb useSandbox $ \mSandboxPkgInfo -> - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - freeze verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb - mSandboxPkgInfo - globalFlags' freezeFlags - -genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () -genBoundsAction freezeFlags _extraArgs globalFlags = do - let verbosity = fromFlag (freezeVerbosity freezeFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config NoFlag - nixShell verbosity distPref globalFlags config $ do - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, progdb) <- configCompilerAux' configFlags - - maybeWithSandboxPackageInfo - verbosity configFlags globalFlags' - comp platform progdb useSandbox $ \mSandboxPkgInfo -> - maybeWithSandboxDirOnSearchPath useSandbox $ - withRepoContext verbosity globalFlags' $ \repoContext -> - genBounds verbosity - (configPackageDB' configFlags) - repoContext - comp platform progdb - mSandboxPkgInfo - globalFlags' freezeFlags - -outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO () -outdatedAction outdatedFlags _extraArgs globalFlags = do - let verbosity = fromFlag (outdatedVerbosity outdatedFlags) - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, platform, _progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - outdated verbosity outdatedFlags repoContext - comp platform - -uploadAction :: UploadFlags -> [String] -> Action -uploadAction uploadFlags extraArgs globalFlags = do - config <- loadConfig verbosity (globalConfigFile globalFlags) - let uploadFlags' = savedUploadFlags config `mappend` uploadFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - tarfiles = extraArgs - when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ - die' verbosity "the 'upload' command expects at least one .tar.gz archive." - checkTarFiles extraArgs - maybe_password <- - case uploadPasswordCmd uploadFlags' - of Flag (xs:xss) -> Just . Password <$> - getProgramInvocationOutput verbosity - (simpleProgramInvocation xs xss) - _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' - withRepoContext verbosity globalFlags' $ \repoContext -> do - if fromFlag (uploadDoc uploadFlags') - then do - when (length tarfiles > 1) $ - die' verbosity $ "the 'upload' command can only upload documentation " - ++ "for one package at a time." - tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles - Upload.uploadDoc verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - (fromFlag (uploadCandidate uploadFlags')) - tarfile - else do - Upload.upload verbosity - repoContext - (flagToMaybe $ uploadUsername uploadFlags') - maybe_password - (fromFlag (uploadCandidate uploadFlags')) - tarfiles - where - verbosity = fromFlag (uploadVerbosity uploadFlags) - checkTarFiles tarfiles - | not (null otherFiles) - = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " - ++ intercalate ", " otherFiles - | otherwise = sequence_ - [ do exists <- doesFileExist tarfile - unless exists $ die' verbosity $ "file not found: " ++ tarfile - | tarfile <- tarfiles ] - - where otherFiles = filter (not . isTarGzFile) tarfiles - isTarGzFile file = case splitExtension file of - (file', ".gz") -> takeExtension file' == ".tar" - _ -> False - generateDocTarball config = do - notice verbosity $ - "No documentation tarball specified. " - ++ "Building a documentation tarball with default settings...\n" - ++ "If you need to customise Haddock options, " - ++ "run 'haddock --for-hackage' first " - ++ "to generate a documentation tarball." - haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) - [] globalFlags - distPref <- findSavedDistPref config NoFlag - pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) - return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" - -checkAction :: Flag Verbosity -> [String] -> Action -checkAction verbosityFlag extraArgs _globalFlags = do - let verbosity = fromFlag verbosityFlag - unless (null extraArgs) $ - die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs - allOk <- Check.check (fromFlag verbosityFlag) - unless allOk exitFailure - -formatAction :: Flag Verbosity -> [String] -> Action -formatAction verbosityFlag extraArgs _globalFlags = do - let verbosity = fromFlag verbosityFlag - path <- case extraArgs of - [] -> do cwd <- getCurrentDirectory - tryFindPackageDesc cwd - (p:_) -> return p - pkgDesc <- readGenericPackageDescription verbosity path - -- Uses 'writeFileAtomic' under the hood. - writeGenericPackageDescription path pkgDesc - -uninstallAction :: Flag Verbosity -> [String] -> Action -uninstallAction verbosityFlag extraArgs _globalFlags = do - let verbosity = fromFlag verbosityFlag - package = case extraArgs of - p:_ -> p - _ -> "PACKAGE_NAME" - die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' " - ++ "operation. " - ++ "It will likely be implemented at some point in the future; " - ++ "in the meantime you're advised to use either 'ghc-pkg unregister " - ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'." - - -sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action -sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do - let verbosity = fromFlag (sDistVerbosity sdistFlags) - unless (null extraArgs) $ - die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs - load <- try (loadConfigOrSandboxConfig verbosity globalFlags) - let config = either (\(SomeException _) -> mempty) snd load - distPref <- findSavedDistPref config (sDistDistPref sdistFlags) - let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref } - sdist sdistFlags' sdistExFlags - -reportAction :: ReportFlags -> [String] -> Action -reportAction reportFlags extraArgs globalFlags = do - let verbosity = fromFlag (reportVerbosity reportFlags) - unless (null extraArgs) $ - die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs - config <- loadConfig verbosity (globalConfigFile globalFlags) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - reportFlags' = savedReportFlags config `mappend` reportFlags - - withRepoContext verbosity globalFlags' $ \repoContext -> - Upload.report verbosity repoContext - (flagToMaybe $ reportUsername reportFlags') - (flagToMaybe $ reportPassword reportFlags') - -runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action -runAction (buildFlags, buildExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (buildDistPref buildFlags) - let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck - (buildOnly buildExFlags) - -- reconfigure also checks if we're in a sandbox and reinstalls add-source - -- deps if needed. - config' <- - reconfigure configureAction - verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) - mempty [] globalFlags config - nixShell verbosity distPref globalFlags config $ do - lbi <- getPersistBuildConfig distPref - (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs - - maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] - - maybeWithSandboxDirOnSearchPath useSandbox $ - run verbosity lbi exe exeArgs - -getAction :: GetFlags -> [String] -> Action -getAction getFlags extraArgs globalFlags = do - let verbosity = fromFlag (getVerbosity getFlags) - targets <- readUserTargets verbosity extraArgs - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> - get verbosity - repoContext - globalFlags' - getFlags - targets - -unpackAction :: GetFlags -> [String] -> Action -unpackAction getFlags extraArgs globalFlags = do - getAction getFlags extraArgs globalFlags - -initAction :: InitFlags -> [String] -> Action -initAction initFlags extraArgs globalFlags = do - let verbosity = fromFlag (initVerbosity initFlags) - when (extraArgs /= []) $ - die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs - (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity - (globalFlags { globalRequireSandbox = Flag False }) - let configFlags = savedConfigureFlags config - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, _, progdb) <- configCompilerAux' configFlags - withRepoContext verbosity globalFlags' $ \repoContext -> - initCabal verbosity - (configPackageDB' configFlags) - repoContext - comp - progdb - initFlags - -sandboxAction :: SandboxFlags -> [String] -> Action -sandboxAction sandboxFlags extraArgs globalFlags = do - let verbosity = fromFlag (sandboxVerbosity sandboxFlags) - case extraArgs of - -- Basic sandbox commands. - ["init"] -> sandboxInit verbosity sandboxFlags globalFlags - ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags - ("add-source":extra) -> do - when (noExtraArgs extra) $ - die' verbosity "The 'sandbox add-source' command expects at least one argument" - sandboxAddSource verbosity extra sandboxFlags globalFlags - ("delete-source":extra) -> do - when (noExtraArgs extra) $ - die' verbosity ("The 'sandbox delete-source' command expects " ++ - "at least one argument") - sandboxDeleteSource verbosity extra sandboxFlags globalFlags - ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags - - -- More advanced commands. - ("hc-pkg":extra) -> do - when (noExtraArgs extra) $ - die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument" - sandboxHcPkg verbosity sandboxFlags globalFlags extra - ["buildopts"] -> die' verbosity "Not implemented!" - - -- Hidden commands. - ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags - - -- Error handling. - [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')" - _ -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs - - where - noExtraArgs = (<1) . length - -execAction :: ExecFlags -> [String] -> Action -execAction execFlags extraArgs globalFlags = do - let verbosity = fromFlag (execVerbosity execFlags) - (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags - distPref <- findSavedDistPref config (execDistPref execFlags) - let configFlags = savedConfigureFlags config - configFlags' = configFlags { configDistPref = Flag distPref } - (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags' - exec verbosity useSandbox comp platform progdb extraArgs - -userConfigAction :: UserConfigFlags -> [String] -> Action -userConfigAction ucflags extraArgs globalFlags = do - let verbosity = fromFlag (userConfigVerbosity ucflags) - force = fromFlag (userConfigForce ucflags) - case extraArgs of - ("init":_) -> do - path <- configFile - fileExists <- doesFileExist path - if (not fileExists || (fileExists && force)) - then void $ createDefaultConfigFile verbosity path - else die' verbosity $ path ++ " already exists." - ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags - ("update":_) -> userConfigUpdate verbosity globalFlags - -- Error handling. - [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" - _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs - where configFile = getConfigFilePath (globalConfigFile globalFlags) - --- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. --- -win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action -win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do - let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) - Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse -win32SelfUpgradeAction _ _ _ = return () - --- | Used as an entry point when cabal-install needs to invoke itself --- as a setup script. This can happen e.g. when doing parallel builds. --- -actAsSetupAction :: ActAsSetupFlags -> [String] -> Action -actAsSetupAction actAsSetupFlags args _globalFlags = - let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) - in case bt of - Simple -> Simple.defaultMainArgs args - Configure -> Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks args - Make -> Make.defaultMainArgs args - Custom -> error "actAsSetupAction Custom" - (UnknownBuildType _) -> error "actAsSetupAction UnknownBuildType" - -manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action -manpageAction commands flagVerbosity extraArgs _ = do - let verbosity = fromFlag flagVerbosity - unless (null extraArgs) $ - die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs - pname <- getProgName - let cabalCmd = if takeExtension pname == ".exe" - then dropExtension pname - else pname - putStrLn $ manpage cabalCmd commands diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -1,4 +1,5 @@ #!/bin/sh +set -e # A script to bootstrap cabal-install. @@ -208,60 +209,47 @@ # Versions of the packages to install. # The version regex says what existing installed versions are ok. -PARSEC_VER="3.1.11"; PARSEC_VER_REGEXP="[3]\.[01]\." - # >= 3.0 && < 3.2 +PARSEC_VER="3.1.13.0"; PARSEC_VER_REGEXP="[3]\.[1]\." + # >= 3.1 && < 3.2 DEEPSEQ_VER="1.4.3.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2 - -case "$GHC_VER" in - 7.4*|7.6*) - # GHC 7.4 or 7.6 - BINARY_VER="0.8.2.1" - BINARY_VER_REGEXP="[0]\.[78]\.[0-2]\." # >= 0.7 && < 0.8.3 - ;; - *) - # GHC >= 7.8 - BINARY_VER="0.8.5.1" - BINARY_VER_REGEXP="[0]\.[78]\." # >= 0.7 && < 0.9 - ;; -esac - - -TEXT_VER="1.2.2.2"; TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))" - # >= 0.2 && < 1.3 -NETWORK_VER="2.6.3.2"; NETWORK_VER_REGEXP="2\.[0-6]\." +BINARY_VER="0.8.3.0"; BINARY_VER_REGEXP="[0]\.[78]\." + # >= 0.7 && < 0.9 +TEXT_VER="1.2.3.0"; TEXT_VER_REGEXP="[1]\.[2]\." + # >= 1.2 && < 1.3 +NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\.(0\.[2-9]|[1-9])" + # >= 2.6.0.2 && < 2.7 +NETWORK_VER="2.6.3.4"; NETWORK_VER_REGEXP="2\.[0-6]\." # >= 2.0 && < 2.7 -NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\." - # >= 2.6 && < 2.7 -CABAL_VER="2.0.1.0"; CABAL_VER_REGEXP="2\.0\.[0-9]" - # >= 2.0 && < 2.1 -TRANS_VER="0.5.4.0"; TRANS_VER_REGEXP="0\.[45]\." +CABAL_VER="2.2.0.1"; CABAL_VER_REGEXP="2\.2\.[0-9]" + # >= 2.2 && < 2.3 +TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 -MTL_VER="2.2.1"; MTL_VER_REGEXP="[2]\." +MTL_VER="2.2.2"; MTL_VER_REGEXP="[2]\." # >= 2.0 && < 3 -HTTP_VER="4000.3.7"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" +HTTP_VER="4000.3.11"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" # >= 4000.2.5 < 4000.4 -ZLIB_VER="0.6.1.2"; ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)" +ZLIB_VER="0.6.2"; ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)" # >= 0.5.3 && <= 0.7 -TIME_VER="1.8.0.2" TIME_VER_REGEXP="1\.[1-8]\.?" +TIME_VER="1.8.0.3" TIME_VER_REGEXP="1\.[1-8]\.?" # >= 1.1 && < 1.9 RANDOM_VER="1.1" RANDOM_VER_REGEXP="1\.[01]\.?" # >= 1 && < 1.2 -STM_VER="2.4.4.1"; STM_VER_REGEXP="2\." +STM_VER="2.4.5.0"; STM_VER_REGEXP="2\." # == 2.* -ASYNC_VER="2.1.1.1"; ASYNC_VER_REGEXP="2\." +HASHABLE_VER="1.2.7.0"; HASHABLE_VER_REGEXP="1\." + # 1.* +ASYNC_VER="2.2.1"; ASYNC_VER_REGEXP="2\." # 2.* -OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?" - # >=1.0.0.0 && <1.2 -OLD_LOCALE_VER="1.0.0.7"; OLD_LOCALE_VER_REGEXP="1\.0\.?" - # >=1.0.0.0 && <1.1 BASE16_BYTESTRING_VER="0.1.1.6"; BASE16_BYTESTRING_VER_REGEXP="0\.1" # 0.1.* BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\." # >=1.0 -CRYPTOHASH_SHA256_VER="0.11.100.1"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?" +CRYPTOHASH_SHA256_VER="0.11.101.0"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?" # 0.11.* -MINTTY_VER="0.1"; MINTTY_VER_REGEXP="0\.1\.?" +RESOLV_VER="0.1.1.1"; RESOLV_VER_REGEXP="0\.1\.[1-9]" + # >= 0.1.1 && < 0.2 +MINTTY_VER="0.1.1"; MINTTY_VER_REGEXP="0\.1\.?" # 0.1.* ECHO_VER="0.1.3"; ECHO_VER_REGEXP="0\.1\.[3-9]" # >= 0.1.3 && < 0.2 @@ -269,19 +257,16 @@ # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?" # 0.0.* -HACKAGE_SECURITY_VER="0.5.2.2"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.(2\.[2-9]|[3-9])" +HACKAGE_SECURITY_VER="0.5.3.0"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.((2\.[2-9]|[3-9])|3)" # >= 0.5.2 && < 0.6 -BYTESTRING_BUILDER_VER="0.10.8.1.0"; BYTESTRING_BUILDER_VER_REGEXP="0\.10\.?" -TAR_VER="0.5.0.3"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?" +TAR_VER="0.5.1.0"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?" # >= 0.5.0.3 && < 0.6 -HASHABLE_VER="1.2.6.1"; HASHABLE_VER_REGEXP="1\." - # 1.* HACKAGE_URL="https://hackage.haskell.org/package" -# Haddock fails for network-2.5.0.0, and for hackage-security for -# GHC <8, c.f. https://github.com/well-typed/hackage-security/issues/149 -NO_DOCS_PACKAGES_VER_REGEXP="network-uri-2\.5\.[0-9]+\.[0-9]+|hackage-security-0\.5\.[0-9]+\.[0-9]+" +# Haddock fails for hackage-security for GHC <8, +# c.f. https://github.com/well-typed/hackage-security/issues/149 +NO_DOCS_PACKAGES_VER_REGEXP="hackage-security-0\.5\.[0-9]+\.[0-9]+" # Cache the list of packages: echo "Checking installed packages for ghc-${GHC_VER}..." @@ -327,11 +312,8 @@ URL_PKGDESC=${HACKAGE_URL}/${PKG}-${VER}/${PKG}.cabal if which ${CURL} > /dev/null then - # TODO: switch back to resuming curl command once - # https://github.com/haskell/hackage-server/issues/111 is resolved - #${CURL} -L --fail -C - -O ${URL_PKG} || die "Failed to download ${PKG}." - ${CURL} -L --fail -O ${URL_PKG} || die "Failed to download ${PKG}." - ${CURL} -L --fail -O ${URL_PKGDESC} \ + ${CURL} -L --fail -C - -O ${URL_PKG} || die "Failed to download ${PKG}." + ${CURL} -L --fail -C - -O ${URL_PKGDESC} \ || die "Failed to download '${PKG}.cabal'." elif which ${WGET} > /dev/null then @@ -368,7 +350,12 @@ [ -x Setup ] && ./Setup clean [ -f Setup ] && rm Setup - ${GHC} --make ${JOBS} Setup -o Setup -XRank2Types -XFlexibleContexts || + PKG_DBS=$(printf '%s\n' "${SCOPE_OF_INSTALLATION}" \ + | sed -e 's/--package-db/-package-db/' \ + -e 's/--global/-global-package-db/' \ + -e 's/--user/-user-package-db/') + + ${GHC} --make ${JOBS} ${PKG_DBS} Setup -o Setup -XRank2Types -XFlexibleContexts || die "Compiling the Setup script failed." [ -x Setup ] || die "The Setup script does not exist or cannot be run" @@ -436,38 +423,6 @@ fi } -# Replicate the flag selection logic for network-uri in the .cabal file. -do_network_uri_pkg () { - # Refresh installed package list. - ${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg-stage2.list \ - || die "running '${GHC_PKG} list' failed" - - NETWORK_URI_DUMMY_VER="2.5.0.0"; NETWORK_URI_DUMMY_VER_REGEXP="2\.5\." # < 2.6 - if egrep " network-2\.[6-9]\." ghc-pkg-stage2.list > /dev/null 2>&1 - then - # Use network >= 2.6 && network-uri >= 2.6 - info_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP} - do_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP} - else - # Use network < 2.6 && network-uri < 2.6 - info_pkg "network-uri" ${NETWORK_URI_DUMMY_VER} \ - ${NETWORK_URI_DUMMY_VER_REGEXP} - do_pkg "network-uri" ${NETWORK_URI_DUMMY_VER} \ - ${NETWORK_URI_DUMMY_VER_REGEXP} - fi -} - -# Conditionally install bytestring-builder if bytestring is < 0.10.2. -do_bytestring_builder_pkg () { - if egrep "bytestring-0\.(9|10\.[0,1])\.?" ghc-pkg-stage2.list > /dev/null 2>&1 - then - info_pkg "bytestring-builder" ${BYTESTRING_BUILDER_VER} \ - ${BYTESTRING_BUILDER_VER_REGEXP} - do_pkg "bytestring-builder" ${BYTESTRING_BUILDER_VER} \ - ${BYTESTRING_BUILDER_VER_REGEXP} - fi -} - # Actually do something! info_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} @@ -477,13 +432,13 @@ info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} info_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} +info_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP} info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} -info_pkg "old-locale" ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP} -info_pkg "old-time" ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP} info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} info_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} info_pkg "stm" ${STM_VER} ${STM_VER_REGEXP} +info_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP} info_pkg "async" ${ASYNC_VER} ${ASYNC_VER_REGEXP} info_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \ ${BASE16_BYTESTRING_VER_REGEXP} @@ -491,12 +446,12 @@ ${BASE64_BYTESTRING_VER_REGEXP} info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ ${CRYPTOHASH_SHA256_VER_REGEXP} +info_pkg "resolv" ${RESOLV_VER} ${RESOLV_VER_REGEXP} info_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} info_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} -info_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP} info_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} @@ -504,24 +459,22 @@ do_pkg "binary" ${BINARY_VER} ${BINARY_VER_REGEXP} do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} -# Install the Cabal library from the local Git clone if possible. -do_Cabal_pkg - +# Cabal might depend on these do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} do_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} -do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} -# We conditionally install network-uri, depending on the network version. -do_network_uri_pkg +# Install the Cabal library from the local Git clone if possible. +do_Cabal_pkg -do_pkg "old-locale" ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP} -do_pkg "old-time" ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP} +do_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP} +do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} do_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} do_pkg "stm" ${STM_VER} ${STM_VER_REGEXP} +do_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP} do_pkg "async" ${ASYNC_VER} ${ASYNC_VER_REGEXP} do_pkg "base16-bytestring" ${BASE16_BYTESTRING_VER} \ ${BASE16_BYTESTRING_VER_REGEXP} @@ -529,17 +482,12 @@ ${BASE64_BYTESTRING_VER_REGEXP} do_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \ ${CRYPTOHASH_SHA256_VER_REGEXP} +do_pkg "resolv" ${RESOLV_VER} ${RESOLV_VER_REGEXP} do_pkg "mintty" ${MINTTY_VER} ${MINTTY_VER_REGEXP} do_pkg "echo" ${ECHO_VER} ${ECHO_VER_REGEXP} do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} do_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} - -# We conditionally install bytestring-builder, depending on the bytestring -# version. -do_bytestring_builder_pkg - do_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} -do_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP} do_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,17 +1,20 @@ Name: cabal-install -Version: 2.0.0.1 +Version: 2.2.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing Haskell software by automating the fetching, configuration, compilation and installation of Haskell libraries and programs. + . + This package only provides an executable and cannot be used as a + library (ignore the module listing below.) homepage: http://www.haskell.org/cabal/ bug-reports: https://github.com/haskell/cabal/issues License: BSD3 License-File: LICENSE Author: Cabal Development Team (see AUTHORS file) Maintainer: Cabal Development Team -Copyright: 2003-2017, Cabal Development Team +Copyright: 2003-2018, Cabal Development Team Category: Distribution Build-type: Custom Cabal-Version: >= 1.10 @@ -19,7 +22,7 @@ README.md bash-completion/cabal bootstrap.sh changelog tests/README.md - -- Generated with '../Cabal/misc/gen-extra-source-files.sh' + -- Generated with 'make gen-extra-source-files' -- Do NOT edit this section manually; instead, run the script. -- BEGIN gen-extra-source-files tests/IntegrationTests2/build/keep-going/cabal.project @@ -62,6 +65,7 @@ tests/IntegrationTests2/targets/exes-disabled/cabal.project tests/IntegrationTests2/targets/exes-disabled/p/p.cabal tests/IntegrationTests2/targets/exes-disabled/q/q.cabal + tests/IntegrationTests2/targets/lib-only/p.cabal tests/IntegrationTests2/targets/libs-disabled/cabal.project tests/IntegrationTests2/targets/libs-disabled/p/p.cabal tests/IntegrationTests2/targets/libs-disabled/q/q.cabal @@ -90,17 +94,10 @@ location: https://github.com/haskell/cabal/ subdir: cabal-install -Flag old-bytestring - description: Use bytestring < 0.10.2 and bytestring-builder - default: False - -Flag old-directory - description: Use directory < 1.2 and old-time - default: False - -Flag network-uri - description: Get Network.URI from the network-uri package +Flag native-dns + description: Enable use of the [resolv](https://hackage.haskell.org/package/resolv) & [windns](https://hackage.haskell.org/package/windns) packages for performing DNS lookups default: True + manual: True Flag debug-expensive-assertions description: Enable expensive assertions for testing or debugging @@ -117,32 +114,32 @@ default: False manual: True -flag parsec - description: Use parsec parser. This requires 'Cabal' library built with its parsec flag enabled. - default: False +flag lib + description: Build cabal-install as a library. Please only use this if you are a cabal-install developer. + Default: False manual: True --- When we do CI, we build our binaries on one machine, and then --- ship them to another machine for testing. Because we use --- static linking (since it makes this sort of redeploy MUCH --- easier), if we build five executables, that means we --- need to ship ALL the Haskell libraries five times. That's --- a waste of space! A better strategy is to statically link --- everything into a single binary. That's what this flag does. +-- Build everything (including the test binaries) as a single static binary +-- instead of 5 discrete binaries. +-- This is useful for CI where we build our binaries on one machine, and then +-- ship them to another machine for testing. Since the test binaries are +-- statically linked (making deployment easier), if we build five executables, +-- that means we need to ship ALL 5 binaries (with 5 versions of all the +-- statically linked libraries) to the test machines. This reduces that to one +-- binary and one set of linked libraries. flag monolithic description: Build cabal-install also with all of its test and support code. Used by our continuous integration. default: False manual: True -executable cabal - main-is: Main.hs - ghc-options: -Wall -fwarn-tabs -rtsopts +library + ghc-options: -Wall -fwarn-tabs if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - other-modules: + exposed-modules: Distribution.Client.BuildReports.Anonymous Distribution.Client.BuildReports.Storage Distribution.Client.BuildReports.Types @@ -151,12 +148,22 @@ Distribution.Client.CmdBench Distribution.Client.CmdBuild Distribution.Client.CmdConfigure + Distribution.Client.CmdUpdate + Distribution.Client.CmdErrorMessages + Distribution.Client.CmdExec Distribution.Client.CmdFreeze Distribution.Client.CmdHaddock + Distribution.Client.CmdInstall Distribution.Client.CmdRepl Distribution.Client.CmdRun Distribution.Client.CmdTest - Distribution.Client.CmdErrorMessages + Distribution.Client.Compat.Directory + Distribution.Client.Compat.ExecutablePath + Distribution.Client.Compat.FileLock + Distribution.Client.Compat.FilePerms + Distribution.Client.Compat.Prelude + Distribution.Client.Compat.Process + Distribution.Client.Compat.Semaphore Distribution.Client.Config Distribution.Client.Configure Distribution.Client.Dependency @@ -167,11 +174,11 @@ Distribution.Client.FetchUtils Distribution.Client.FileMonitor Distribution.Client.Freeze + Distribution.Client.GZipUtils Distribution.Client.GenBounds Distribution.Client.Get Distribution.Client.Glob Distribution.Client.GlobalFlags - Distribution.Client.GZipUtils Distribution.Client.Haddock Distribution.Client.HttpUtils Distribution.Client.IndexUtils @@ -194,12 +201,12 @@ Distribution.Client.ProjectBuilding Distribution.Client.ProjectBuilding.Types Distribution.Client.ProjectConfig - Distribution.Client.ProjectConfig.Types Distribution.Client.ProjectConfig.Legacy + Distribution.Client.ProjectConfig.Types Distribution.Client.ProjectOrchestration + Distribution.Client.ProjectPlanOutput Distribution.Client.ProjectPlanning Distribution.Client.ProjectPlanning.Types - Distribution.Client.ProjectPlanOutput Distribution.Client.RebuildMonad Distribution.Client.Reconfigure Distribution.Client.Run @@ -213,48 +220,23 @@ Distribution.Client.Security.HTTP Distribution.Client.Setup Distribution.Client.SetupWrapper - Distribution.Client.SrcDist Distribution.Client.SolverInstallPlan Distribution.Client.SourceFiles + Distribution.Client.SourceRepoParse + Distribution.Client.SrcDist Distribution.Client.Store Distribution.Client.Tar - Distribution.Client.Targets Distribution.Client.TargetSelector + Distribution.Client.Targets Distribution.Client.Types Distribution.Client.Update Distribution.Client.Upload Distribution.Client.Utils Distribution.Client.Utils.Assertion Distribution.Client.Utils.Json - Distribution.Client.World Distribution.Client.Win32SelfUpgrade - Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FileLock - Distribution.Client.Compat.FilePerms - Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Process - Distribution.Client.Compat.Semaphore - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable + Distribution.Client.World + Distribution.Solver.Compat.Prelude Distribution.Solver.Modular Distribution.Solver.Modular.Assignment Distribution.Solver.Modular.Builder @@ -267,13 +249,13 @@ Distribution.Solver.Modular.Flag Distribution.Solver.Modular.Index Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.Linking Distribution.Solver.Modular.LabeledGraph + Distribution.Solver.Modular.Linking Distribution.Solver.Modular.Log Distribution.Solver.Modular.Message + Distribution.Solver.Modular.PSQ Distribution.Solver.Modular.Package Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.PSQ Distribution.Solver.Modular.RetryLog Distribution.Solver.Modular.Solver Distribution.Solver.Modular.Tree @@ -281,6 +263,27 @@ Distribution.Solver.Modular.Var Distribution.Solver.Modular.Version Distribution.Solver.Modular.WeightedPSQ + Distribution.Solver.Types.ComponentDeps + Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.DependencyResolver + Distribution.Solver.Types.Flag + Distribution.Solver.Types.InstSolverPackage + Distribution.Solver.Types.InstalledPreference + Distribution.Solver.Types.LabeledPackageConstraint + Distribution.Solver.Types.OptionalStanza + Distribution.Solver.Types.PackageConstraint + Distribution.Solver.Types.PackageFixedDeps + Distribution.Solver.Types.PackageIndex + Distribution.Solver.Types.PackagePath + Distribution.Solver.Types.PackagePreferences + Distribution.Solver.Types.PkgConfigDb + Distribution.Solver.Types.Progress + Distribution.Solver.Types.ResolverPackage + Distribution.Solver.Types.Settings + Distribution.Solver.Types.SolverId + Distribution.Solver.Types.SolverPackage + Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Variable Paths_cabal_install -- NOTE: when updating build-depends, don't forget to update version regexps @@ -290,19 +293,23 @@ array >= 0.4 && < 0.6, base >= 4.5 && < 5, base16-bytestring >= 0.1.1 && < 0.2, - binary >= 0.5 && < 0.9, - bytestring >= 0.9 && < 1, - Cabal >= 2.0 && < 2.1, + binary >= 0.7 && < 0.9, + bytestring >= 0.10.2 && < 1, + Cabal >= 2.2 && < 2.3, containers >= 0.4 && < 0.6, cryptohash-sha256 >= 0.11 && < 0.12, deepseq >= 1.3 && < 1.5, + directory >= 1.2.2.0 && < 1.4, echo >= 0.1.3 && < 0.2, edit-distance >= 0.2.2 && < 0.3, filepath >= 1.3 && < 1.5, hashable >= 1.0 && < 2, HTTP >= 4000.1.5 && < 4000.4, mtl >= 2.0 && < 3, + network-uri >= 2.6.0.2 && < 2.7, + network >= 2.6 && < 2.7, pretty >= 1.1 && < 1.2, + process >= 1.1.0.2 && < 1.7, random >= 1 && < 1.2, stm >= 2.0 && < 3, tar >= 0.5.0.3 && < 0.6, @@ -310,42 +317,17 @@ zlib >= 0.5.3 && < 0.7, hackage-security >= 0.5.2.2 && < 0.6 - if flag(old-bytestring) - build-depends: bytestring < 0.10.2, bytestring-builder >= 0.10 && < 1 - else - build-depends: bytestring >= 0.10.2 - - if flag(old-directory) - build-depends: directory >= 1.1 && < 1.2, old-time >= 1 && < 1.2, - process >= 1.0.1.1 && < 1.1.0.2 - else - build-depends: directory >= 1.2 && < 1.4, - process >= 1.1.0.2 && < 1.7 - - -- NOTE: you MUST include the network dependency even when network-uri - -- is pulled in, otherwise the constraint solver doesn't have enough - -- information - if flag(network-uri) - build-depends: network-uri >= 2.6 && < 2.7, network >= 2.6 && < 2.7 - else - build-depends: network >= 2.4 && < 2.6 - - -- Needed for GHC.Generics before GHC 7.6 - if impl(ghc < 7.6) - build-depends: ghc-prim >= 0.2 && < 0.3 + if flag(native-dns) + if os(windows) + build-depends: windns >= 0.1.0 && < 0.2 + else + build-depends: resolv >= 0.1.1 && < 0.2 if os(windows) build-depends: Win32 >= 2 && < 3 else build-depends: unix >= 2.5 && < 2.8 - if !(arch(arm) && impl(ghc < 7.6)) - ghc-options: -threaded - - -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a - if os(aix) - extra-libraries: bsd - if flag(debug-expensive-assertions) cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS @@ -357,14 +339,237 @@ cpp-options: -DDEBUG_TRACETREE build-depends: tracetree >= 0.1 && < 0.2 - if flag(parsec) - cpp-options: -DCABAL_PARSEC + if !flag(lib) + buildable: False - hs-source-dirs: . + default-language: Haskell2010 + +executable cabal + main-is: Main.hs + hs-source-dirs: main + + ghc-options: -Wall -fwarn-tabs -rtsopts + if impl(ghc >= 8.0) + ghc-options: -Wcompat + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances + + other-modules: Paths_cabal_install + + if flag(lib) + build-depends: + cabal-install, + Cabal >= 2.2 && < 2.3, + base, + directory, + filepath + else + hs-source-dirs: . + build-depends: + async >= 2.0 && < 3, + array >= 0.4 && < 0.6, + base >= 4.5 && < 5, + base16-bytestring >= 0.1.1 && < 0.2, + binary >= 0.7 && < 0.9, + bytestring >= 0.10.2 && < 1, + Cabal >= 2.2 && < 2.3, + containers >= 0.4 && < 0.6, + cryptohash-sha256 >= 0.11 && < 0.12, + deepseq >= 1.3 && < 1.5, + directory >= 1.2.2.0 && < 1.4, + echo >= 0.1.3 && < 0.2, + edit-distance >= 0.2.2 && < 0.3, + filepath >= 1.3 && < 1.5, + hashable >= 1.0 && < 2, + HTTP >= 4000.1.5 && < 4000.4, + mtl >= 2.0 && < 3, + network >= 2.6 && < 2.7, + network-uri >= 2.6 && < 2.7, + pretty >= 1.1 && < 1.2, + process >= 1.2 && < 1.7, + random >= 1 && < 1.2, + stm >= 2.0 && < 3, + tar >= 0.5.0.3 && < 0.6, + time >= 1.4 && < 1.9, + zlib >= 0.5.3 && < 0.7, + hackage-security >= 0.5.2.2 && < 0.6 + + other-modules: + Distribution.Client.BuildReports.Anonymous + Distribution.Client.BuildReports.Storage + Distribution.Client.BuildReports.Types + Distribution.Client.BuildReports.Upload + Distribution.Client.Check + Distribution.Client.CmdBench + Distribution.Client.CmdBuild + Distribution.Client.CmdConfigure + Distribution.Client.CmdUpdate + Distribution.Client.CmdErrorMessages + Distribution.Client.CmdExec + Distribution.Client.CmdFreeze + Distribution.Client.CmdHaddock + Distribution.Client.CmdInstall + Distribution.Client.CmdRepl + Distribution.Client.CmdRun + Distribution.Client.CmdTest + Distribution.Client.Compat.Directory + Distribution.Client.Compat.ExecutablePath + Distribution.Client.Compat.FileLock + Distribution.Client.Compat.FilePerms + Distribution.Client.Compat.Prelude + Distribution.Client.Compat.Process + Distribution.Client.Compat.Semaphore + Distribution.Client.Config + Distribution.Client.Configure + Distribution.Client.Dependency + Distribution.Client.Dependency.Types + Distribution.Client.DistDirLayout + Distribution.Client.Exec + Distribution.Client.Fetch + Distribution.Client.FetchUtils + Distribution.Client.FileMonitor + Distribution.Client.Freeze + Distribution.Client.GZipUtils + Distribution.Client.GenBounds + Distribution.Client.Get + Distribution.Client.Glob + Distribution.Client.GlobalFlags + Distribution.Client.Haddock + Distribution.Client.HttpUtils + Distribution.Client.IndexUtils + Distribution.Client.IndexUtils.Timestamp + Distribution.Client.Init + Distribution.Client.Init.Heuristics + Distribution.Client.Init.Licenses + Distribution.Client.Init.Types + Distribution.Client.Install + Distribution.Client.InstallPlan + Distribution.Client.InstallSymlink + Distribution.Client.JobControl + Distribution.Client.List + Distribution.Client.Manpage + Distribution.Client.Nix + Distribution.Client.Outdated + Distribution.Client.PackageHash + Distribution.Client.PackageUtils + Distribution.Client.ParseUtils + Distribution.Client.ProjectBuilding + Distribution.Client.ProjectBuilding.Types + Distribution.Client.ProjectConfig + Distribution.Client.ProjectConfig.Legacy + Distribution.Client.ProjectConfig.Types + Distribution.Client.ProjectOrchestration + Distribution.Client.ProjectPlanOutput + Distribution.Client.ProjectPlanning + Distribution.Client.ProjectPlanning.Types + Distribution.Client.RebuildMonad + Distribution.Client.Reconfigure + Distribution.Client.Run + Distribution.Client.Sandbox + Distribution.Client.Sandbox.Index + Distribution.Client.Sandbox.PackageEnvironment + Distribution.Client.Sandbox.Timestamp + Distribution.Client.Sandbox.Types + Distribution.Client.SavedFlags + Distribution.Client.Security.DNS + Distribution.Client.Security.HTTP + Distribution.Client.Setup + Distribution.Client.SetupWrapper + Distribution.Client.SolverInstallPlan + Distribution.Client.SourceFiles + Distribution.Client.SourceRepoParse + Distribution.Client.SrcDist + Distribution.Client.Store + Distribution.Client.Tar + Distribution.Client.TargetSelector + Distribution.Client.Targets + Distribution.Client.Types + Distribution.Client.Update + Distribution.Client.Upload + Distribution.Client.Utils + Distribution.Client.Utils.Assertion + Distribution.Client.Utils.Json + Distribution.Client.Win32SelfUpgrade + Distribution.Client.World + Distribution.Solver.Compat.Prelude + Distribution.Solver.Modular + Distribution.Solver.Modular.Assignment + Distribution.Solver.Modular.Builder + Distribution.Solver.Modular.Configured + Distribution.Solver.Modular.ConfiguredConversion + Distribution.Solver.Modular.ConflictSet + Distribution.Solver.Modular.Cycles + Distribution.Solver.Modular.Dependency + Distribution.Solver.Modular.Explore + Distribution.Solver.Modular.Flag + Distribution.Solver.Modular.Index + Distribution.Solver.Modular.IndexConversion + Distribution.Solver.Modular.LabeledGraph + Distribution.Solver.Modular.Linking + Distribution.Solver.Modular.Log + Distribution.Solver.Modular.Message + Distribution.Solver.Modular.PSQ + Distribution.Solver.Modular.Package + Distribution.Solver.Modular.Preference + Distribution.Solver.Modular.RetryLog + Distribution.Solver.Modular.Solver + Distribution.Solver.Modular.Tree + Distribution.Solver.Modular.Validate + Distribution.Solver.Modular.Var + Distribution.Solver.Modular.Version + Distribution.Solver.Modular.WeightedPSQ + Distribution.Solver.Types.ComponentDeps + Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.DependencyResolver + Distribution.Solver.Types.Flag + Distribution.Solver.Types.InstSolverPackage + Distribution.Solver.Types.InstalledPreference + Distribution.Solver.Types.LabeledPackageConstraint + Distribution.Solver.Types.OptionalStanza + Distribution.Solver.Types.PackageConstraint + Distribution.Solver.Types.PackageFixedDeps + Distribution.Solver.Types.PackageIndex + Distribution.Solver.Types.PackagePath + Distribution.Solver.Types.PackagePreferences + Distribution.Solver.Types.PkgConfigDb + Distribution.Solver.Types.Progress + Distribution.Solver.Types.ResolverPackage + Distribution.Solver.Types.Settings + Distribution.Solver.Types.SolverId + Distribution.Solver.Types.SolverPackage + Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Variable + + if flag(native-dns) + if os(windows) + build-depends: windns >= 0.1.0 && < 0.2 + else + build-depends: resolv >= 0.1.1 && < 0.2 + + if os(windows) + build-depends: Win32 >= 2 && < 3 + else + build-depends: unix >= 2.5 && < 2.8 + + if flag(debug-expensive-assertions) + cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS + + if flag(debug-conflict-sets) + cpp-options: -DDEBUG_CONFLICT_SETS + build-depends: base >= 4.8 + + if flag(debug-tracetree) + cpp-options: -DDEBUG_TRACETREE + build-depends: tracetree >= 0.1 && < 0.2 + if flag(monolithic) hs-source-dirs: tests other-modules: UnitTests + MemoryUsageTests + SolverQuickCheck + IntegrationTests2 + UnitTests.Distribution.Client.ArbitraryInstances UnitTests.Distribution.Client.FileMonitor UnitTests.Distribution.Client.GZipUtils @@ -379,21 +584,20 @@ UnitTests.Distribution.Client.Tar UnitTests.Distribution.Client.Targets UnitTests.Distribution.Client.UserConfig + UnitTests.Distribution.Solver.Modular.Builder UnitTests.Distribution.Solver.Modular.DSL UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils UnitTests.Distribution.Solver.Modular.MemoryUsage - UnitTests.Distribution.Solver.Modular.PSQ UnitTests.Distribution.Solver.Modular.QuickCheck + UnitTests.Distribution.Solver.Modular.QuickCheck.Utils UnitTests.Distribution.Solver.Modular.RetryLog UnitTests.Distribution.Solver.Modular.Solver UnitTests.Distribution.Solver.Modular.WeightedPSQ UnitTests.Options - MemoryUsageTests - SolverQuickCheck - IntegrationTests2 + cpp-options: -DMONOLITHIC build-depends: - Cabal >= 2.0 && < 2.1, + Cabal >= 2.2 && < 2.3, QuickCheck >= 2.8.2, array, async, @@ -403,210 +607,84 @@ directory, edit-distance, filepath, + hashable, mtl, network, network-uri, - pretty-show, + pretty-show >= 1.6.15, random, tagged, tar, - tasty >= 0.12, + tasty >= 1.0 && < 1.1, tasty-hunit >= 0.10, tasty-quickcheck, time, zlib + ghc-options: -threaded + + -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a + if os(aix) + extra-libraries: bsd + default-language: Haskell2010 -- Small, fast running tests. Test-Suite unit-tests type: exitcode-stdio-1.0 main-is: UnitTests.hs - hs-source-dirs: tests, . + hs-source-dirs: tests ghc-options: -Wall -fwarn-tabs -main-is UnitTests other-modules: - Distribution.Client.BuildReports.Anonymous - Distribution.Client.BuildReports.Storage - Distribution.Client.BuildReports.Types - Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FileLock - Distribution.Client.Compat.FilePerms - Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Semaphore - Distribution.Client.Config - Distribution.Client.Configure - Distribution.Client.Dependency - Distribution.Client.Dependency.Types - Distribution.Client.DistDirLayout - Distribution.Client.FetchUtils - Distribution.Client.FileMonitor - Distribution.Client.GZipUtils - Distribution.Client.Glob - Distribution.Client.GlobalFlags - Distribution.Client.Haddock - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils - Distribution.Client.IndexUtils.Timestamp - Distribution.Client.Init.Types - Distribution.Client.Install - Distribution.Client.InstallPlan - Distribution.Client.InstallSymlink - Distribution.Client.JobControl - Distribution.Client.PackageUtils - Distribution.Client.ParseUtils - Distribution.Client.ProjectConfig - Distribution.Client.ProjectConfig.Legacy - Distribution.Client.ProjectConfig.Types - Distribution.Client.RebuildMonad - Distribution.Client.Sandbox - Distribution.Client.Sandbox.Index - Distribution.Client.Sandbox.PackageEnvironment - Distribution.Client.Sandbox.Timestamp - Distribution.Client.Sandbox.Types - Distribution.Client.SavedFlags - Distribution.Client.Security.DNS - Distribution.Client.Security.HTTP - Distribution.Client.Setup - Distribution.Client.SetupWrapper - Distribution.Client.SolverInstallPlan - Distribution.Client.SrcDist - Distribution.Client.Store - Distribution.Client.Tar - Distribution.Client.Targets - Distribution.Client.Types - Distribution.Client.Utils - Distribution.Client.Utils.Assertion - Distribution.Client.Win32SelfUpgrade - Distribution.Client.World - Distribution.Solver.Modular - Distribution.Solver.Modular.Assignment - Distribution.Solver.Modular.Builder - Distribution.Solver.Modular.Configured - Distribution.Solver.Modular.ConfiguredConversion - Distribution.Solver.Modular.ConflictSet - Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Dependency - Distribution.Solver.Modular.Explore - Distribution.Solver.Modular.Flag - Distribution.Solver.Modular.Index - Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.LabeledGraph - Distribution.Solver.Modular.Linking - Distribution.Solver.Modular.Log - Distribution.Solver.Modular.Message - Distribution.Solver.Modular.PSQ - Distribution.Solver.Modular.Package - Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.RetryLog - Distribution.Solver.Modular.Solver - Distribution.Solver.Modular.Tree - Distribution.Solver.Modular.Validate - Distribution.Solver.Modular.Var - Distribution.Solver.Modular.Version - Distribution.Solver.Modular.WeightedPSQ - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable - Paths_cabal_install UnitTests.Distribution.Client.ArbitraryInstances + UnitTests.Distribution.Client.Targets UnitTests.Distribution.Client.FileMonitor - UnitTests.Distribution.Client.GZipUtils UnitTests.Distribution.Client.Glob - UnitTests.Distribution.Client.IndexUtils.Timestamp - UnitTests.Distribution.Client.InstallPlan - UnitTests.Distribution.Client.JobControl - UnitTests.Distribution.Client.ProjectConfig + UnitTests.Distribution.Client.GZipUtils UnitTests.Distribution.Client.Sandbox UnitTests.Distribution.Client.Sandbox.Timestamp UnitTests.Distribution.Client.Store UnitTests.Distribution.Client.Tar - UnitTests.Distribution.Client.Targets UnitTests.Distribution.Client.UserConfig - UnitTests.Distribution.Solver.Modular.DSL - UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - UnitTests.Distribution.Solver.Modular.PSQ + UnitTests.Distribution.Client.ProjectConfig + UnitTests.Distribution.Client.JobControl + UnitTests.Distribution.Client.IndexUtils.Timestamp + UnitTests.Distribution.Client.InstallPlan + UnitTests.Distribution.Solver.Modular.Builder UnitTests.Distribution.Solver.Modular.RetryLog UnitTests.Distribution.Solver.Modular.Solver + UnitTests.Distribution.Solver.Modular.DSL + UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils UnitTests.Distribution.Solver.Modular.WeightedPSQ UnitTests.Options - build-depends: + array, base, async, - array, bytestring, + cabal-install, Cabal, containers, deepseq, mtl, - pretty, - process, + random, directory, filepath, - hashable, - stm, tar, time, - HTTP, zlib, - binary, - random, - hackage-security, - tasty >= 0.12, + network-uri, + network, + tasty >= 1.0 && < 1.1, tasty-hunit >= 0.10, tasty-quickcheck, tagged, QuickCheck >= 2.8.2 - if flag(old-directory) - build-depends: old-time - - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network-uri < 2.6, network < 2.6 - - if impl(ghc < 7.6) - build-depends: ghc-prim >= 0.2 && < 0.3 - - if os(windows) - build-depends: Win32 - else - build-depends: unix - - ghc-options: -fno-ignore-asserts - - if !(arch(arm) && impl(ghc < 7.6)) - ghc-options: -threaded - - if flag(debug-expensive-assertions) - cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS - - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 + ghc-options: -threaded - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 + if !flag(lib) + buildable: False default-language: Haskell2010 @@ -614,75 +692,9 @@ Test-Suite memory-usage-tests type: exitcode-stdio-1.0 main-is: MemoryUsageTests.hs - hs-source-dirs: tests, . + hs-source-dirs: tests ghc-options: -Wall -fwarn-tabs "-with-rtsopts=-M4M -K1K" -main-is MemoryUsageTests other-modules: - Distribution.Client.Compat.Prelude - Distribution.Client.Dependency - Distribution.Client.Dependency.Types - Distribution.Client.FetchUtils - Distribution.Client.GZipUtils - Distribution.Client.GlobalFlags - Distribution.Client.HttpUtils - Distribution.Client.PackageUtils - Distribution.Client.Sandbox.Types - Distribution.Client.Security.DNS - Distribution.Client.Security.HTTP - Distribution.Client.SolverInstallPlan - Distribution.Client.Tar - Distribution.Client.Targets - Distribution.Client.Types - Distribution.Client.Utils - Distribution.Client.Utils.Assertion - Distribution.Client.World - Distribution.Solver.Modular - Distribution.Solver.Modular.Assignment - Distribution.Solver.Modular.Builder - Distribution.Solver.Modular.Configured - Distribution.Solver.Modular.ConfiguredConversion - Distribution.Solver.Modular.ConflictSet - Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Dependency - Distribution.Solver.Modular.Explore - Distribution.Solver.Modular.Flag - Distribution.Solver.Modular.Index - Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.LabeledGraph - Distribution.Solver.Modular.Linking - Distribution.Solver.Modular.Log - Distribution.Solver.Modular.Message - Distribution.Solver.Modular.PSQ - Distribution.Solver.Modular.Package - Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.RetryLog - Distribution.Solver.Modular.Solver - Distribution.Solver.Modular.Tree - Distribution.Solver.Modular.Validate - Distribution.Solver.Modular.Var - Distribution.Solver.Modular.Version - Distribution.Solver.Modular.WeightedPSQ - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable - Paths_cabal_install UnitTests.Distribution.Solver.Modular.DSL UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils UnitTests.Distribution.Solver.Modular.MemoryUsage @@ -690,60 +702,18 @@ build-depends: base, async, - array, - bytestring, Cabal, + cabal-install, containers, deepseq, - mtl, - pretty, - process, - directory, - filepath, - hashable, - stm, - tar, - time, - HTTP, - zlib, - binary, - random, - hackage-security, tagged, - tasty >= 0.12, + tasty >= 1.0 && < 1.1, tasty-hunit >= 0.10 - if flag(old-directory) - build-depends: old-time - - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network-uri < 2.6, network < 2.6 - - if impl(ghc < 7.6) - build-depends: ghc-prim >= 0.2 && < 0.3 - - if os(windows) - build-depends: Win32 - else - build-depends: unix - - ghc-options: -fno-ignore-asserts - - if !(arch(arm) && impl(ghc < 7.6)) - ghc-options: -threaded - - if flag(debug-expensive-assertions) - cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS - - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 + ghc-options: -threaded - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 + if !flag(lib) + buildable: False default-language: Haskell2010 @@ -751,137 +721,31 @@ Test-Suite solver-quickcheck type: exitcode-stdio-1.0 main-is: SolverQuickCheck.hs - hs-source-dirs: tests, . - ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts -main-is SolverQuickCheck + hs-source-dirs: tests + ghc-options: -Wall -fwarn-tabs -main-is SolverQuickCheck other-modules: - Distribution.Client.BuildReports.Types - Distribution.Client.Compat.Prelude - Distribution.Client.Dependency - Distribution.Client.Dependency.Types - Distribution.Client.FetchUtils - Distribution.Client.GZipUtils - Distribution.Client.GlobalFlags - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils.Timestamp - Distribution.Client.Init.Types - Distribution.Client.PackageUtils - Distribution.Client.Sandbox.Types - Distribution.Client.Security.DNS - Distribution.Client.Security.HTTP - Distribution.Client.Setup - Distribution.Client.SolverInstallPlan - Distribution.Client.Tar - Distribution.Client.Targets - Distribution.Client.Types - Distribution.Client.Utils - Distribution.Client.Utils.Assertion - Distribution.Client.World - Distribution.Solver.Modular - Distribution.Solver.Modular.Assignment - Distribution.Solver.Modular.Builder - Distribution.Solver.Modular.Configured - Distribution.Solver.Modular.ConfiguredConversion - Distribution.Solver.Modular.ConflictSet - Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Dependency - Distribution.Solver.Modular.Explore - Distribution.Solver.Modular.Flag - Distribution.Solver.Modular.Index - Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.LabeledGraph - Distribution.Solver.Modular.Linking - Distribution.Solver.Modular.Log - Distribution.Solver.Modular.Message - Distribution.Solver.Modular.PSQ - Distribution.Solver.Modular.Package - Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.RetryLog - Distribution.Solver.Modular.Solver - Distribution.Solver.Modular.Tree - Distribution.Solver.Modular.Validate - Distribution.Solver.Modular.Var - Distribution.Solver.Modular.Version - Distribution.Solver.Modular.WeightedPSQ - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable - Paths_cabal_install UnitTests.Distribution.Solver.Modular.DSL UnitTests.Distribution.Solver.Modular.QuickCheck + UnitTests.Distribution.Solver.Modular.QuickCheck.Utils build-depends: base, async, - array, - bytestring, Cabal, + cabal-install, containers, deepseq >= 1.2, - mtl, - pretty, - process, - directory, - filepath, hashable, - stm, - tar, - time, - HTTP, - zlib, - binary, random, - hackage-security, - tasty >= 0.12, + tagged, + tasty >= 1.0 && <1.1, tasty-quickcheck, QuickCheck >= 2.8.2, - pretty-show - - if flag(old-directory) - build-depends: old-time - - if flag(network-uri) - build-depends: network-uri >= 2.6, network >= 2.6 - else - build-depends: network-uri < 2.6, network < 2.6 - - if impl(ghc < 7.6) - build-depends: ghc-prim >= 0.2 && < 0.3 - - if os(windows) - build-depends: Win32 - else - build-depends: unix - - if !(arch(arm) && impl(ghc < 7.6)) - ghc-options: -threaded - - if flag(debug-expensive-assertions) - cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS + pretty-show >= 1.6.15 - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 + ghc-options: -threaded - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 + if !flag(lib) + buildable: False default-language: Haskell2010 @@ -890,167 +754,30 @@ test-suite integration-tests2 type: exitcode-stdio-1.0 main-is: IntegrationTests2.hs - hs-source-dirs: tests, . - ghc-options: -Wall -fwarn-tabs -fno-ignore-asserts -main-is IntegrationTests2 + hs-source-dirs: tests + ghc-options: -Wall -fwarn-tabs -main-is IntegrationTests2 other-modules: - Distribution.Client.BuildReports.Types - Distribution.Client.CmdBench - Distribution.Client.CmdBuild - Distribution.Client.CmdErrorMessages - Distribution.Client.CmdHaddock - Distribution.Client.CmdRepl - Distribution.Client.CmdRun - Distribution.Client.CmdTest - Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FileLock - Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Semaphore - Distribution.Client.Config - Distribution.Client.Dependency - Distribution.Client.Dependency.Types - Distribution.Client.DistDirLayout - Distribution.Client.FetchUtils - Distribution.Client.FileMonitor - Distribution.Client.GZipUtils - Distribution.Client.Glob - Distribution.Client.GlobalFlags - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils - Distribution.Client.IndexUtils.Timestamp - Distribution.Client.Init.Types - Distribution.Client.InstallPlan - Distribution.Client.JobControl - Distribution.Client.PackageHash - Distribution.Client.PackageUtils - Distribution.Client.ParseUtils - Distribution.Client.ProjectBuilding - Distribution.Client.ProjectBuilding.Types - Distribution.Client.ProjectConfig - Distribution.Client.ProjectConfig.Legacy - Distribution.Client.ProjectConfig.Types - Distribution.Client.ProjectOrchestration - Distribution.Client.ProjectPlanOutput - Distribution.Client.ProjectPlanning - Distribution.Client.ProjectPlanning.Types - Distribution.Client.RebuildMonad - Distribution.Client.Sandbox.Types - Distribution.Client.Security.DNS - Distribution.Client.Security.HTTP - Distribution.Client.Setup - Distribution.Client.SetupWrapper - Distribution.Client.SolverInstallPlan - Distribution.Client.SourceFiles - Distribution.Client.SrcDist - Distribution.Client.Store - Distribution.Client.Tar - Distribution.Client.TargetSelector - Distribution.Client.Targets - Distribution.Client.Types - Distribution.Client.Utils - Distribution.Client.Utils.Assertion - Distribution.Client.Utils.Json - Distribution.Client.World - Distribution.Solver.Modular - Distribution.Solver.Modular.Assignment - Distribution.Solver.Modular.Builder - Distribution.Solver.Modular.Configured - Distribution.Solver.Modular.ConfiguredConversion - Distribution.Solver.Modular.ConflictSet - Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Dependency - Distribution.Solver.Modular.Explore - Distribution.Solver.Modular.Flag - Distribution.Solver.Modular.Index - Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.LabeledGraph - Distribution.Solver.Modular.Linking - Distribution.Solver.Modular.Log - Distribution.Solver.Modular.Message - Distribution.Solver.Modular.PSQ - Distribution.Solver.Modular.Package - Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.RetryLog - Distribution.Solver.Modular.Solver - Distribution.Solver.Modular.Tree - Distribution.Solver.Modular.Validate - Distribution.Solver.Modular.Var - Distribution.Solver.Modular.Version - Distribution.Solver.Modular.WeightedPSQ - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable - Paths_cabal_install build-depends: - async, - array, base, - base16-bytestring, - binary, - bytestring, Cabal, + cabal-install, containers, - cryptohash-sha256, deepseq, directory, edit-distance, filepath, - hackage-security, - hashable, - HTTP, - mtl, - network, - network-uri, - pretty, - process, - random, - stm, - tar, - time, - zlib, - tasty >= 0.12, + tasty >= 1.0 && < 1.1, tasty-hunit >= 0.10, tagged - if flag(old-bytestring) - build-depends: bytestring-builder - - if flag(old-directory) - build-depends: old-time - - if impl(ghc < 7.6) - build-depends: ghc-prim >= 0.2 && < 0.3 - - if os(windows) - build-depends: Win32 - else - build-depends: unix + if !flag(lib) + buildable: False - if arch(arm) - cc-options: -DCABAL_NO_THREADED - else - ghc-options: -threaded + ghc-options: -threaded default-language: Haskell2010 custom-setup - setup-depends: Cabal >= 2.0, + setup-depends: Cabal >= 2.2, base, process >= 1.1.0.1 && < 1.7, - filepath >= 1.3 && < 1.5 + filepath >= 1.3 && < 1.5 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,75 @@ -*-change-log-*- +2.2.0.0 Mikhail Glushenkov March 2018 + * '--with-PROG' and '--PROG-options' are applied to all packages + and not local packages only (#5019). + * Completed the 'new-update' command (#4809), which respects nix-style + cabal.project(.local) files and allows to update from + multiple repositories when using overlays. + * Completed the 'new-run' command (#4477). The functionality is the + same of the old 'run' command but using nix-style builds. + Additionally, it can run executables across packages in a project. + Tests and benchmarks are also treated as executables, providing a + quick way to pass them arguments. + * Completed the 'new-bench' command (#3638). Same as above. + * Completed the 'new-exec' command (#3638). Same as above. + * Added a preliminary 'new-install' command (#4558, nonlocal exes + part) which allows to quickly install executables from Hackage. + * Set symlink-bindir (used by new-install) to .cabal/bin by default on + .cabal/config initialization (#5188). + * 'cabal update' now supports '--index-state' which can be used to + roll back the index to an earlier state. + * '--allow-{newer,older}' syntax has been enhanced. Dependency + relaxation can be now limited to a specific release of a package, + plus there's a new syntax for relaxing only caret-style (i.e. '^>=') + dependencies (#4575, #4669). + * New config file field: 'cxx-options' to specify which options to be + passed to the compiler when compiling C++ sources specified by the + 'cxx-sources' field. (#3700) + * New config file field: 'cxx-sources' to specify C++ files to be + compiled separately from C source files. Useful in conjunction with the + 'cxx-options' flag to pass different compiler options to C and C++ + source files. (#3700) + * Use [lfxtb] letters to differentiate component kind instead of + opaque "c" in dist-dir layout. + * 'cabal configure' now supports '--enable-static', which can be + used to build static libaries with GHC via GHC's `-staticlib` + flag. + * 'cabal user-config now supports '--augment' which can append + additional lines to a new or updated cabal config file. + * Added support for '--enable-tests' and '--enable-benchmarks' to + 'cabal fetch' (#4948). + * Misspelled package-names on CLI will no longer be silently + case-corrected (#4778). + * 'cabal new-configure' now backs up the old 'cabal.project.local' + file if it exists (#4460). + * On macOS, `new-build` will now place dynamic libraries into + `store/lib` and aggressively shorten their names in an effort to + stay within the load command size limits of macOSs mach-o linker. + * 'new-build' now checks for the existence of executables for + build-tools and build-tool-depends dependencies in the solver + (#4884). + * Fixed a spurious warning telling the user to run 'cabal update' + when it wasn't necessary (#4444). + * Packages installed in sandboxes via 'add-source' now have + their timestamps updated correctly and so will not be reinstalled + unncecessarily if the main install command fails (#1375). + * Add Windows device path support for copyFile, renameFile. Allows cabal + new-build to use temporary store path of up to 32k length + (#3972, #4914, #4515). + * When a flag value is specified multiple times on the command + line, the last one is now preferred, so e.g. '-f+dev -f-dev' is + now equivalent to '-f-dev' (#4452). + * Removed support for building cabal-install with GHC < 7.10 (#4870). + * New 'package *' section in 'cabal.project' files that applies + options to all packages, not just those local to the project. + * Paths_ autogen modules now compile when `RebindableSyntax` or + `OverloadedStrings` is used in `default-extensions`. + [stack#3789](https://github.com/commercialhaskell/stack/issues/3789) + * getDataDir` and other `Paths_autogen` functions now work + correctly when compiling a custom `Setup.hs` script using + `new-build` (#5164). + 2.0.0.1 Mikhail Glushenkov December 2017 * Support for GHC's numeric -g debug levels (#4673). * Demoted 'scope' field version check to a warning (#4714). @@ -155,7 +225,8 @@ 1.22.7.0 Ryan Thomas December 2015 * Remove GZipUtils tests - * maybeDecompress: bail on all errors at the beginning of the stream with zlib < 0.6 + * maybeDecompress: bail on all errors at the beginning of the + stream with zlib < 0.6 * Correct maybeDecompress 1.22.6.0 Ryan Thomas June 2015 @@ -167,10 +238,12 @@ 1.22.4.0 Ryan Thomas May 2015 * Force cabal upload to always use digest auth and never basic auth. * Add dependency-graph information to `printPlan` output - * bootstrap.sh: fixes linker matching to avoid cases where tested linker names appear unexpectedly in compiler output (fixes #2542) + * bootstrap.sh: fixes linker matching to avoid cases where tested + linker names appear unexpectedly in compiler output (fixes #2542) 1.22.3.0 Ryan Thomas April 2015 - * Fix bash completion for sandbox subcommands - Fixes #2513 (Mikhail Glushenkov) + * Fix bash completion for sandbox subcommands - Fixes #2513 + (Mikhail Glushenkov) * filterConfigureFlags: filter more flags (Mikhail Glushenkov) 1.22.2.0 Ryan Thomas March 2015 diff --git a/main/Main.hs b/main/Main.hs new file mode 100644 --- /dev/null +++ b/main/Main.hs @@ -0,0 +1,1229 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Entry point to the default cabal-install front-end. +----------------------------------------------------------------------------- + +module Main (main) where + +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand, withRepoContext + , ConfigFlags(..) + , ConfigExFlags(..), defaultConfigExFlags, configureExCommand + , reconfigureCommand + , configCompilerAux', configPackageDB' + , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) + , buildCommand, replCommand, testCommand, benchmarkCommand + , InstallFlags(..), defaultInstallFlags + , installCommand, upgradeCommand, uninstallCommand + , FetchFlags(..), fetchCommand + , FreezeFlags(..), freezeCommand + , genBoundsCommand + , OutdatedFlags(..), outdatedCommand + , GetFlags(..), getCommand, unpackCommand + , checkCommand + , formatCommand + , UpdateFlags(..), updateCommand + , ListFlags(..), listCommand + , InfoFlags(..), infoCommand + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand + , runCommand + , InitFlags(initVerbosity), initCommand + , SDistFlags(..), SDistExFlags(..), sdistCommand + , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand + , ActAsSetupFlags(..), actAsSetupCommand + , SandboxFlags(..), sandboxCommand + , ExecFlags(..), execCommand + , UserConfigFlags(..), userConfigCommand + , reportCommand + , manpageCommand + ) +import Distribution.Simple.Setup + ( HaddockTarget(..) + , DoctestFlags(..), doctestCommand + , HaddockFlags(..), haddockCommand, defaultHaddockFlags + , HscolourFlags(..), hscolourCommand + , ReplFlags(..) + , CopyFlags(..), copyCommand + , RegisterFlags(..), registerCommand + , CleanFlags(..), cleanCommand + , TestFlags(..), BenchmarkFlags(..) + , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag + , configAbsolutePaths + ) + +import Prelude () +import Distribution.Solver.Compat.Prelude hiding (get) + +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Config + ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff + , userConfigUpdate, createDefaultConfigFile, getConfigFilePath ) +import Distribution.Client.Targets + ( readUserTargets ) +import qualified Distribution.Client.List as List + ( list, info ) + + +import qualified Distribution.Client.CmdConfigure as CmdConfigure +import qualified Distribution.Client.CmdUpdate as CmdUpdate +import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdRepl as CmdRepl +import qualified Distribution.Client.CmdFreeze as CmdFreeze +import qualified Distribution.Client.CmdHaddock as CmdHaddock +import qualified Distribution.Client.CmdInstall as CmdInstall +import qualified Distribution.Client.CmdRun as CmdRun +import qualified Distribution.Client.CmdTest as CmdTest +import qualified Distribution.Client.CmdBench as CmdBench +import qualified Distribution.Client.CmdExec as CmdExec + +import Distribution.Client.Install (install) +import Distribution.Client.Configure (configure, writeConfigFlags) +import Distribution.Client.Update (update) +import Distribution.Client.Exec (exec) +import Distribution.Client.Fetch (fetch) +import Distribution.Client.Freeze (freeze) +import Distribution.Client.GenBounds (genBounds) +import Distribution.Client.Outdated (outdated) +import Distribution.Client.Check as Check (check) +--import Distribution.Client.Clean (clean) +import qualified Distribution.Client.Upload as Upload +import Distribution.Client.Run (run, splitRunArgs) +import Distribution.Client.SrcDist (sdist) +import Distribution.Client.Get (get) +import Distribution.Client.Reconfigure (Check(..), reconfigure) +import Distribution.Client.Nix (nixInstantiate + ,nixShell + ,nixShellIfSandboxed) +import Distribution.Client.Sandbox (sandboxInit + ,sandboxAddSource + ,sandboxDelete + ,sandboxDeleteSource + ,sandboxListSources + ,sandboxHcPkg + ,dumpPackageEnvironment + + ,loadConfigOrSandboxConfig + ,findSavedDistPref + ,initPackageDBIfNeeded + ,maybeWithSandboxDirOnSearchPath + ,maybeWithSandboxPackageInfo + ,tryGetIndexFilePath + ,sandboxBuildDir + ,updateSandboxConfigFileFlag + ,updateInstallDirs + + ,getPersistOrConfigCompiler) +import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB) +import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) +import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) +import Distribution.Client.Tar (createTarGzFile) +import Distribution.Client.Types (Password (..)) +import Distribution.Client.Init (initCabal) +import Distribution.Client.Manpage (manpage) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade +import Distribution.Client.Utils (determineNumJobs +#if defined(mingw32_HOST_OS) + ,relaxEncodingErrors +#endif + ) + +import Distribution.Package (packageId) +import Distribution.PackageDescription + ( BuildType(..), Executable(..), buildable ) +import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) + +import Distribution.PackageDescription.PrettyPrint + ( writeGenericPackageDescription ) +import qualified Distribution.Simple as Simple +import qualified Distribution.Make as Make +import qualified Distribution.Types.UnqualComponentName as Make +import Distribution.Simple.Build + ( startInterpreter ) +import Distribution.Simple.Command + ( CommandParse(..), CommandUI(..), Command, CommandSpec(..) + , CommandType(..), commandsRun, commandAddAction, hiddenCommand + , commandFromSpec, commandShowOptions ) +import Distribution.Simple.Compiler (Compiler(..), PackageDBStack) +import Distribution.Simple.Configure + ( configCompilerAuxEx, ConfigStateFileError(..) + , getPersistBuildConfig, interpretPackageDbFlags + , tryGetPersistBuildConfig ) +import qualified Distribution.Simple.LocalBuildInfo as LBI +import Distribution.Simple.Program (defaultProgramDb + ,configureAllKnownPrograms + ,simpleProgramInvocation + ,getProgramInvocationOutput) +import Distribution.Simple.Program.Db (reconfigurePrograms) +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Simple.Utils + ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler + , findPackageDesc, tryFindPackageDesc ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal ) +import Distribution.Version + ( Version, mkVersion, orLaterVersion ) +import qualified Paths_cabal_install (version) + +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath ( dropExtension, splitExtension + , takeExtension, (), (<.>)) +import System.IO ( BufferMode(LineBuffering), hSetBuffering +#ifdef mingw32_HOST_OS + , stderr +#endif + , stdout ) +import System.Directory (doesFileExist, getCurrentDirectory) +import Data.Monoid (Any(..)) +import Control.Exception (SomeException(..), try) +import Control.Monad (mapM_) + +#ifdef MONOLITHIC +import qualified UnitTests +import qualified MemoryUsageTests +import qualified SolverQuickCheck +import qualified IntegrationTests2 +import qualified System.Environment as Monolithic +#endif + +-- | Entry point +-- +main :: IO () +#ifdef MONOLITHIC +main = do + mb_exec <- Monolithic.lookupEnv "CABAL_INSTALL_MONOLITHIC_MODE" + case mb_exec of + Just "UnitTests" -> UnitTests.main + Just "MemoryUsageTests" -> MemoryUsageTests.main + Just "SolverQuickCheck" -> SolverQuickCheck.main + Just "IntegrationTests2" -> IntegrationTests2.main + Just s -> error $ "Unrecognized mode '" ++ show s ++ "' in CABAL_INSTALL_MONOLITHIC_MODE" + Nothing -> main' +#else +main = main' +#endif + +main' :: IO () +main' = do + -- Enable line buffering so that we can get fast feedback even when piped. + -- This is especially important for CI and build systems. + hSetBuffering stdout LineBuffering + -- The default locale encoding for Windows CLI is not UTF-8 and printing + -- Unicode characters to it will fail unless we relax the handling of encoding + -- errors when writing to stderr and stdout. +#ifdef mingw32_HOST_OS + relaxEncodingErrors stdout + relaxEncodingErrors stderr +#endif + getArgs >>= mainWorker + +mainWorker :: [String] -> IO () +mainWorker args = topHandler $ + case commandsRun (globalCommand commands) commands args of + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> + case commandParse of + _ | fromFlagOrDefault False (globalVersion globalFlags) + -> printVersion + | fromFlagOrDefault False (globalNumericVersion globalFlags) + -> printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> do + globalFlags' <- updateSandboxConfigFileFlag globalFlags + action globalFlags' + + where + printCommandHelp help = do + pname <- getProgName + putStr (help pname) + printGlobalHelp help = do + pname <- getProgName + configFile <- defaultConfigFile + putStr (help pname) + putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" + ++ " " ++ configFile ++ "\n" + exists <- doesFileExist configFile + unless exists $ + putStrLn $ "This file will be generated with sensible " + ++ "defaults if you run 'cabal update'." + printOptionsList = putStr . unlines + printErrors errs = dieNoVerbosity $ intercalate "\n" errs + printNumericVersion = putStrLn $ display Paths_cabal_install.version + printVersion = putStrLn $ "cabal-install version " + ++ display Paths_cabal_install.version + ++ "\ncompiled using version " + ++ display cabalVersion + ++ " of the Cabal library " + + commands = map commandFromSpec commandSpecs + commandSpecs = + [ regularCmd installCommand installAction + , regularCmd updateCommand updateAction + , regularCmd listCommand listAction + , regularCmd infoCommand infoAction + , regularCmd fetchCommand fetchAction + , regularCmd freezeCommand freezeAction + , regularCmd getCommand getAction + , hiddenCmd unpackCommand unpackAction + , regularCmd checkCommand checkAction + , regularCmd sdistCommand sdistAction + , regularCmd uploadCommand uploadAction + , regularCmd reportCommand reportAction + , regularCmd runCommand runAction + , regularCmd initCommand initAction + , regularCmd configureExCommand configureAction + , regularCmd reconfigureCommand reconfigureAction + , regularCmd buildCommand buildAction + , regularCmd replCommand replAction + , regularCmd sandboxCommand sandboxAction + , regularCmd doctestCommand doctestAction + , regularCmd haddockCommand haddockAction + , regularCmd execCommand execAction + , regularCmd userConfigCommand userConfigAction + , regularCmd cleanCommand cleanAction + , regularCmd genBoundsCommand genBoundsAction + , regularCmd outdatedCommand outdatedAction + , wrapperCmd copyCommand copyVerbosity copyDistPref + , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref + , wrapperCmd registerCommand regVerbosity regDistPref + , regularCmd testCommand testAction + , regularCmd benchmarkCommand benchmarkAction + , hiddenCmd uninstallCommand uninstallAction + , hiddenCmd formatCommand formatAction + , hiddenCmd upgradeCommand upgradeAction + , hiddenCmd win32SelfUpgradeCommand win32SelfUpgradeAction + , hiddenCmd actAsSetupCommand actAsSetupAction + , hiddenCmd manpageCommand (manpageAction commandSpecs) + + , regularCmd CmdConfigure.configureCommand CmdConfigure.configureAction + , regularCmd CmdUpdate.updateCommand CmdUpdate.updateAction + , regularCmd CmdBuild.buildCommand CmdBuild.buildAction + , regularCmd CmdRepl.replCommand CmdRepl.replAction + , regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction + , regularCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction + , regularCmd CmdInstall.installCommand CmdInstall.installAction + , regularCmd CmdRun.runCommand CmdRun.runAction + , regularCmd CmdTest.testCommand CmdTest.testAction + , regularCmd CmdBench.benchCommand CmdBench.benchAction + , regularCmd CmdExec.execCommand CmdExec.execAction + ] + +type Action = GlobalFlags -> IO () + +regularCmd :: CommandUI flags -> (flags -> [String] -> action) + -> CommandSpec action +regularCmd ui action = + CommandSpec ui ((flip commandAddAction) action) NormalCommand + +hiddenCmd :: CommandUI flags -> (flags -> [String] -> action) + -> CommandSpec action +hiddenCmd ui action = + CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action)) + HiddenCommand + +wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity) + -> (flags -> Flag String) -> CommandSpec Action +wrapperCmd ui verbosity distPref = + CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand + +wrapperAction :: Monoid flags + => CommandUI flags + -> (flags -> Flag Verbosity) + -> (flags -> Flag String) + -> Command Action +wrapperAction command verbosityFlag distPrefFlag = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do + let verbosity = fromFlagOrDefault normal (verbosityFlag flags) + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (distPrefFlag flags) + let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } + setupWrapper verbosity setupScriptOptions Nothing + command (const flags) extraArgs + +configureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> Action +configureAction (configFlags, configExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (configDistPref configFlags) + nixInstantiate verbosity distPref True globalFlags config + nixShell verbosity distPref globalFlags config $ do + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAuxEx configFlags' + + -- If we're working inside a sandbox and the user has set the -w option, we + -- may need to create a sandbox-local package DB for this compiler and add a + -- timestamp record for this compiler to the timestamp file. + let configFlags'' = case useSandbox of + NoSandbox -> configFlags' + (UseSandbox sandboxDir) -> setPackageDB sandboxDir + comp platform configFlags' + + writeConfigFlags verbosity distPref (configFlags'', configExFlags') + + -- What package database(s) to use + let packageDBs :: PackageDBStack + packageDBs + = interpretPackageDbFlags + (fromFlag (configUserInstall configFlags'')) + (configPackageDBs configFlags'') + + whenUsingSandbox useSandbox $ \sandboxDir -> do + initPackageDBIfNeeded verbosity configFlags'' comp progdb + -- NOTE: We do not write the new sandbox package DB location to + -- 'cabal.sandbox.config' here because 'configure -w' must not affect + -- subsequent 'install' (for UI compatibility with non-sandboxed mode). + + indexFile <- tryGetIndexFilePath verbosity config + maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile + (compilerId comp) platform + + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verbosity globalFlags' $ \repoContext -> + configure verbosity packageDBs repoContext + comp platform progdb configFlags'' configExFlags' extraArgs + +reconfigureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> Action +reconfigureAction flags@(configFlags, _) _ globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (configDistPref configFlags) + let checkFlags = Check $ \_ saved -> do + let flags' = saved <> flags + unless (saved == flags') $ info verbosity message + pure (Any True, flags') + where + -- This message is correct, but not very specific: it will list all + -- of the new flags, even if some have not actually changed. The + -- *minimal* set of changes is more difficult to determine. + message = + "flags changed: " + ++ unwords (commandShowOptions configureExCommand flags) + nixInstantiate verbosity distPref True globalFlags config + _ <- + reconfigure configureAction + verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag + checkFlags [] globalFlags config + pure () + +buildAction :: (BuildFlags, BuildExFlags) -> [String] -> Action +buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (buildDistPref buildFlags) + -- Calls 'configureAction' to do the real work, so nothing special has to be + -- done to support sandboxes. + config' <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config' distPref buildFlags extraArgs + + +-- | Actually do the work of building the package. This is separate from +-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke +-- 'reconfigure' twice. +build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () +build verbosity config distPref buildFlags extraArgs = + setupWrapper verbosity setupOptions Nothing + (Cabal.buildCommand progDb) mkBuildFlags extraArgs + where + progDb = defaultProgramDb + setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + + mkBuildFlags version = filterBuildFlags version config buildFlags' + buildFlags' = buildFlags + { buildVerbosity = toFlag verbosity + , buildDistPref = toFlag distPref + } + +-- | Make sure that we don't pass new flags to setup scripts compiled against +-- old versions of Cabal. +filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags +filterBuildFlags version config buildFlags + | version >= mkVersion [1,19,1] = buildFlags_latest + -- Cabal < 1.19.1 doesn't support 'build -j'. + | otherwise = buildFlags_pre_1_19_1 + where + buildFlags_pre_1_19_1 = buildFlags { + buildNumJobs = NoFlag + } + buildFlags_latest = buildFlags { + -- Take the 'jobs' setting '~/.cabal/config' into account. + buildNumJobs = Flag . Just . determineNumJobs $ + (numJobsConfigFlag `mappend` numJobsCmdLineFlag) + } + numJobsConfigFlag = installNumJobs . savedInstallFlags $ config + numJobsCmdLineFlag = buildNumJobs buildFlags + + +replAction :: (ReplFlags, BuildExFlags) -> [String] -> Action +replAction (replFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (replVerbosity replFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (replDistPref replFlags) + cwd <- getCurrentDirectory + pkgDesc <- findPackageDesc cwd + let + -- There is a .cabal file in the current directory: start a REPL and load + -- the project's modules. + onPkgDesc = do + let noAddSource = case replReload replFlags of + Flag True -> SkipAddSourceDepsCheck + _ -> fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + -- Calls 'configureAction' to do the real work, so nothing special has to + -- be done to support sandboxes. + _ <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource NoFlag + mempty [] globalFlags config + let progDb = defaultProgramDb + setupOptions = defaultSetupScriptOptions + { useCabalVersion = orLaterVersion $ mkVersion [1,18,0] + , useDistPref = distPref + } + replFlags' = replFlags + { replVerbosity = toFlag verbosity + , replDistPref = toFlag distPref + } + + nixShell verbosity distPref globalFlags config $ do + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + (Cabal.replCommand progDb) (const replFlags') extraArgs + + -- No .cabal file in the current directory: just start the REPL (possibly + -- using the sandbox package DB). + onNoPkgDesc = do + let configFlags = savedConfigureFlags config + (comp, platform, programDb) <- configCompilerAux' configFlags + programDb' <- reconfigurePrograms verbosity + (replProgramPaths replFlags) + (replProgramArgs replFlags) + programDb + nixShell verbosity distPref globalFlags config $ do + startInterpreter verbosity programDb' comp platform + (configPackageDB' configFlags) + + either (const onNoPkgDesc) (const onPkgDesc) pkgDesc + +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> Action +installAction (configFlags, _, installFlags, _) _ globalFlags + | fromFlagOrDefault False (installOnly installFlags) = do + let verb = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags + dist <- findSavedDistPref config (configDistPref configFlags) + let setupOpts = defaultSetupScriptOptions { useDistPref = dist } + nixShellIfSandboxed verb dist globalFlags config useSandbox $ + setupWrapper + verb setupOpts Nothing + installCommand (const mempty) [] + +installAction + (configFlags, configExFlags, installFlags, haddockFlags) + extraArgs globalFlags = do + let verb = fromFlagOrDefault normal (configVerbosity configFlags) + (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) + <$> loadConfigOrSandboxConfig verb globalFlags + + let sandboxDist = + case useSandbox of + NoSandbox -> NoFlag + UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir + dist <- findSavedDistPref config + (configDistPref configFlags `mappend` sandboxDist) + + nixShellIfSandboxed verb dist globalFlags config useSandbox $ do + targets <- readUserTargets verb extraArgs + + -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to + -- 'configure' when run inside a sandbox. Right now, running + -- + -- $ cabal sandbox init && cabal configure -w /path/to/ghc + -- && cabal build && cabal install + -- + -- performs the compilation twice unless you also pass -w to 'install'. + -- However, this is the same behaviour that 'cabal install' has in the normal + -- mode of operation, so we stick to it for consistency. + + let configFlags' = maybeForceTests installFlags' $ + savedConfigureFlags config `mappend` + configFlags { configDistPref = toFlag dist } + configExFlags' = defaultConfigExFlags `mappend` + savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + haddockFlags' = defaultHaddockFlags `mappend` + savedHaddockFlags config `mappend` + haddockFlags { haddockDistPref = toFlag dist } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags' + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the + -- future. + progdb' <- configureAllKnownPrograms verb progdb + + -- If we're working inside a sandbox and the user has set the -w option, we + -- may need to create a sandbox-local package DB for this compiler and add a + -- timestamp record for this compiler to the timestamp file. + configFlags'' <- case useSandbox of + NoSandbox -> configAbsolutePaths $ configFlags' + (UseSandbox sandboxDir) -> return $ setPackageDB sandboxDir comp platform + configFlags' + + whenUsingSandbox useSandbox $ \sandboxDir -> do + initPackageDBIfNeeded verb configFlags'' comp progdb' + + indexFile <- tryGetIndexFilePath verb config + maybeAddCompilerTimestampRecord verb sandboxDir indexFile + (compilerId comp) platform + + -- TODO: Passing 'SandboxPackageInfo' to install unconditionally here means + -- that 'cabal install some-package' inside a sandbox will sometimes reinstall + -- modified add-source deps, even if they are not among the dependencies of + -- 'some-package'. This can also prevent packages that depend on older + -- versions of add-source'd packages from building (see #1362). + maybeWithSandboxPackageInfo verb configFlags'' globalFlags' + comp platform progdb useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verb globalFlags' $ \repoContext -> + install verb + (configPackageDB' configFlags'') + repoContext + comp platform progdb' + useSandbox mSandboxPkgInfo + globalFlags' configFlags'' configExFlags' + installFlags' haddockFlags' + targets + + where + -- '--run-tests' implies '--enable-tests'. + maybeForceTests installFlags' configFlags' = + if fromFlagOrDefault False (installRunTests installFlags') + then configFlags' { configTests = toFlag True } + else configFlags' + +testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags + -> IO () +testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (testVerbosity testFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (testDistPref testFlags) + let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + buildFlags' = buildFlags + { buildVerbosity = testVerbosity testFlags } + checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> + if fromFlagOrDefault False (configTests configFlags) + then pure (mempty, flags) + else do + info verbosity "reconfiguring to enable tests" + let flags' = ( configFlags { configTests = toFlag True } + , configExFlags + ) + pure (Any True, flags') + + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + _ <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') + checkFlags [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + testFlags' = testFlags { testDistPref = toFlag distPref } + + -- The package was just configured, so the LBI must be available. + names <- componentNamesFromLBI verbosity distPref "test suites" + (\c -> case c of { LBI.CTest{} -> True; _ -> False }) + let extraArgs' + | null extraArgs = case names of + ComponentNamesUnknown -> [] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CTestName name <- names' ] + | otherwise = extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config distPref buildFlags' extraArgs' + + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + Cabal.testCommand (const testFlags') extraArgs' + +data ComponentNames = ComponentNamesUnknown + | ComponentNames [LBI.ComponentName] + +-- | Return the names of all buildable components matching a given predicate. +componentNamesFromLBI :: Verbosity -> FilePath -> String + -> (LBI.Component -> Bool) + -> IO ComponentNames +componentNamesFromLBI verbosity distPref targetsDescr compPred = do + eLBI <- tryGetPersistBuildConfig distPref + case eLBI of + Left err -> case err of + -- Note: the build config could have been generated by a custom setup + -- script built against a different Cabal version, so it's crucial that + -- we ignore the bad version error here. + ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown + _ -> die' verbosity (show err) + Right lbi -> do + let pkgDescr = LBI.localPkgDescr lbi + names = map LBI.componentName + . filter (buildable . LBI.componentBuildInfo) + . filter compPred $ + LBI.pkgComponents pkgDescr + if null names + then do notice verbosity $ "Package has no buildable " + ++ targetsDescr ++ "." + exitSuccess -- See #3215. + + else return $! (ComponentNames names) + +benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags) + -> [String] -> GlobalFlags + -> IO () +benchmarkAction + (benchmarkFlags, buildFlags, buildExFlags) + extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal + (benchmarkVerbosity benchmarkFlags) + + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags) + let buildFlags' = buildFlags + { buildVerbosity = benchmarkVerbosity benchmarkFlags } + noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + + let checkFlags = Check $ \_ flags@(configFlags, configExFlags) -> + if fromFlagOrDefault False (configBenchmarks configFlags) + then pure (mempty, flags) + else do + info verbosity "reconfiguring to enable benchmarks" + let flags' = ( configFlags { configBenchmarks = toFlag True } + , configExFlags + ) + pure (Any True, flags') + + + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + config' <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags') + checkFlags [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let setupOptions = defaultSetupScriptOptions { useDistPref = distPref } + benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref } + + -- The package was just configured, so the LBI must be available. + names <- componentNamesFromLBI verbosity distPref "benchmarks" + (\c -> case c of { LBI.CBench{} -> True; _ -> False; }) + let extraArgs' + | null extraArgs = case names of + ComponentNamesUnknown -> [] + ComponentNames names' -> [ Make.unUnqualComponentName name + | LBI.CBenchName name <- names'] + | otherwise = extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config' distPref buildFlags' extraArgs' + + maybeWithSandboxDirOnSearchPath useSandbox $ + setupWrapper verbosity setupOptions Nothing + Cabal.benchmarkCommand (const benchmarkFlags') extraArgs' + +haddockAction :: HaddockFlags -> [String] -> Action +haddockAction haddockFlags extraArgs globalFlags = do + let verbosity = fromFlag (haddockVerbosity haddockFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (haddockDistPref haddockFlags) + config' <- + reconfigure configureAction + verbosity distPref useSandbox DontSkipAddSourceDepsCheck NoFlag + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + let haddockFlags' = defaultHaddockFlags `mappend` + savedHaddockFlags config' `mappend` + haddockFlags { haddockDistPref = toFlag distPref } + setupScriptOptions = defaultSetupScriptOptions + { useDistPref = distPref } + setupWrapper verbosity setupScriptOptions Nothing + haddockCommand (const haddockFlags') extraArgs + when (haddockForHackage haddockFlags == Flag ForHackage) $ do + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) + let dest = distPref name <.> "tar.gz" + name = display (packageId pkg) ++ "-docs" + docDir = distPref "doc" "html" + createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + +doctestAction :: DoctestFlags -> [String] -> Action +doctestAction doctestFlags extraArgs _globalFlags = do + let verbosity = fromFlag (doctestVerbosity doctestFlags) + + setupWrapper verbosity defaultSetupScriptOptions Nothing + doctestCommand (const doctestFlags) extraArgs + +cleanAction :: CleanFlags -> [String] -> Action +cleanAction cleanFlags extraArgs globalFlags = do + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (cleanDistPref cleanFlags) + let setupScriptOptions = defaultSetupScriptOptions + { useDistPref = distPref + , useWin32CleanHack = True + } + cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } + setupWrapper verbosity setupScriptOptions Nothing + cleanCommand (const cleanFlags') extraArgs + where + verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) + +listAction :: ListFlags -> [String] -> Action +listAction listFlags extraArgs globalFlags = do + let verbosity = fromFlag (listVerbosity listFlags) + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let configFlags' = savedConfigureFlags config + configFlags = configFlags' { + configPackageDBs = configPackageDBs configFlags' + `mappend` listPackageDBs listFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + List.list verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + listFlags + extraArgs + +infoAction :: InfoFlags -> [String] -> Action +infoAction infoFlags extraArgs globalFlags = do + let verbosity = fromFlag (infoVerbosity infoFlags) + targets <- readUserTargets verbosity extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let configFlags' = savedConfigureFlags config + configFlags = configFlags' { + configPackageDBs = configPackageDBs configFlags' + `mappend` infoPackageDBs infoFlags + } + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAuxEx configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + List.info verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + globalFlags' + infoFlags + targets + +updateAction :: UpdateFlags -> [String] -> Action +updateAction updateFlags extraArgs globalFlags = do + let verbosity = fromFlag (updateVerbosity updateFlags) + unless (null extraArgs) $ + die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + update verbosity updateFlags repoContext + +upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) + -> [String] -> Action +upgradeAction (configFlags, _, _, _) _ _ = die' verbosity $ + "Use the 'cabal install' command instead of 'cabal upgrade'.\n" + ++ "You can install the latest version of a package using 'cabal install'. " + ++ "The 'cabal upgrade' command has been removed because people found it " + ++ "confusing and it often led to broken packages.\n" + ++ "If you want the old upgrade behaviour then use the install command " + ++ "with the --upgrade-dependencies flag (but check first with --dry-run " + ++ "to see what would happen). This will try to pick the latest versions " + ++ "of all dependencies, rather than the usual behaviour of trying to pick " + ++ "installed versions of all dependencies. If you do use " + ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " + ++ "packages (e.g. by using appropriate --constraint= flags)." + where + verbosity = fromFlag (configVerbosity configFlags) + +fetchAction :: FetchFlags -> [String] -> Action +fetchAction fetchFlags extraArgs globalFlags = do + let verbosity = fromFlag (fetchVerbosity fetchFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + fetch verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb globalFlags' fetchFlags + targets + +freezeAction :: FreezeFlags -> [String] -> Action +freezeAction freezeFlags _extraArgs globalFlags = do + let verbosity = fromFlag (freezeVerbosity freezeFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config NoFlag + nixShell verbosity distPref globalFlags config $ do + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + + maybeWithSandboxPackageInfo + verbosity configFlags globalFlags' + comp platform progdb useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verbosity globalFlags' $ \repoContext -> + freeze verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb + mSandboxPkgInfo + globalFlags' freezeFlags + +genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO () +genBoundsAction freezeFlags _extraArgs globalFlags = do + let verbosity = fromFlag (freezeVerbosity freezeFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config NoFlag + nixShell verbosity distPref globalFlags config $ do + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, progdb) <- configCompilerAux' configFlags + + maybeWithSandboxPackageInfo + verbosity configFlags globalFlags' + comp platform progdb useSandbox $ \mSandboxPkgInfo -> + maybeWithSandboxDirOnSearchPath useSandbox $ + withRepoContext verbosity globalFlags' $ \repoContext -> + genBounds verbosity + (configPackageDB' configFlags) + repoContext + comp platform progdb + mSandboxPkgInfo + globalFlags' freezeFlags + +outdatedAction :: OutdatedFlags -> [String] -> GlobalFlags -> IO () +outdatedAction outdatedFlags _extraArgs globalFlags = do + let verbosity = fromFlag (outdatedVerbosity outdatedFlags) + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, platform, _progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + outdated verbosity outdatedFlags repoContext + comp platform + +uploadAction :: UploadFlags -> [String] -> Action +uploadAction uploadFlags extraArgs globalFlags = do + config <- loadConfig verbosity (globalConfigFile globalFlags) + let uploadFlags' = savedUploadFlags config `mappend` uploadFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + tarfiles = extraArgs + when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $ + die' verbosity "the 'upload' command expects at least one .tar.gz archive." + checkTarFiles extraArgs + maybe_password <- + case uploadPasswordCmd uploadFlags' + of Flag (xs:xss) -> Just . Password <$> + getProgramInvocationOutput verbosity + (simpleProgramInvocation xs xss) + _ -> pure $ flagToMaybe $ uploadPassword uploadFlags' + withRepoContext verbosity globalFlags' $ \repoContext -> do + if fromFlag (uploadDoc uploadFlags') + then do + when (length tarfiles > 1) $ + die' verbosity $ "the 'upload' command can only upload documentation " + ++ "for one package at a time." + tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles + Upload.uploadDoc verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfile + else do + Upload.upload verbosity + repoContext + (flagToMaybe $ uploadUsername uploadFlags') + maybe_password + (fromFlag (uploadCandidate uploadFlags')) + tarfiles + where + verbosity = fromFlag (uploadVerbosity uploadFlags) + checkTarFiles tarfiles + | not (null otherFiles) + = die' verbosity $ "the 'upload' command expects only .tar.gz archives: " + ++ intercalate ", " otherFiles + | otherwise = sequence_ + [ do exists <- doesFileExist tarfile + unless exists $ die' verbosity $ "file not found: " ++ tarfile + | tarfile <- tarfiles ] + + where otherFiles = filter (not . isTarGzFile) tarfiles + isTarGzFile file = case splitExtension file of + (file', ".gz") -> takeExtension file' == ".tar" + _ -> False + generateDocTarball config = do + notice verbosity $ + "No documentation tarball specified. " + ++ "Building a documentation tarball with default settings...\n" + ++ "If you need to customise Haddock options, " + ++ "run 'haddock --for-hackage' first " + ++ "to generate a documentation tarball." + haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage }) + [] globalFlags + distPref <- findSavedDistPref config NoFlag + pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) + return $ distPref display (packageId pkg) ++ "-docs" <.> "tar.gz" + +checkAction :: Flag Verbosity -> [String] -> Action +checkAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + unless (null extraArgs) $ + die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs + allOk <- Check.check (fromFlag verbosityFlag) + unless allOk exitFailure + +formatAction :: Flag Verbosity -> [String] -> Action +formatAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + path <- case extraArgs of + [] -> do cwd <- getCurrentDirectory + tryFindPackageDesc cwd + (p:_) -> return p + pkgDesc <- readGenericPackageDescription verbosity path + -- Uses 'writeFileAtomic' under the hood. + writeGenericPackageDescription path pkgDesc + +uninstallAction :: Flag Verbosity -> [String] -> Action +uninstallAction verbosityFlag extraArgs _globalFlags = do + let verbosity = fromFlag verbosityFlag + package = case extraArgs of + p:_ -> p + _ -> "PACKAGE_NAME" + die' verbosity $ "This version of 'cabal-install' does not support the 'uninstall' " + ++ "operation. " + ++ "It will likely be implemented at some point in the future; " + ++ "in the meantime you're advised to use either 'ghc-pkg unregister " + ++ package ++ "' or 'cabal sandbox hc-pkg -- unregister " ++ package ++ "'." + + +sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> Action +sdistAction (sdistFlags, sdistExFlags) extraArgs globalFlags = do + let verbosity = fromFlag (sDistVerbosity sdistFlags) + unless (null extraArgs) $ + die' verbosity $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs + load <- try (loadConfigOrSandboxConfig verbosity globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (sDistDistPref sdistFlags) + let sdistFlags' = sdistFlags { sDistDistPref = toFlag distPref } + sdist sdistFlags' sdistExFlags + +reportAction :: ReportFlags -> [String] -> Action +reportAction reportFlags extraArgs globalFlags = do + let verbosity = fromFlag (reportVerbosity reportFlags) + unless (null extraArgs) $ + die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + reportFlags' = savedReportFlags config `mappend` reportFlags + + withRepoContext verbosity globalFlags' $ \repoContext -> + Upload.report verbosity repoContext + (flagToMaybe $ reportUsername reportFlags') + (flagToMaybe $ reportPassword reportFlags') + +runAction :: (BuildFlags, BuildExFlags) -> [String] -> Action +runAction (buildFlags, buildExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (buildDistPref buildFlags) + let noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) + -- reconfigure also checks if we're in a sandbox and reinstalls add-source + -- deps if needed. + config' <- + reconfigure configureAction + verbosity distPref useSandbox noAddSource (buildNumJobs buildFlags) + mempty [] globalFlags config + nixShell verbosity distPref globalFlags config $ do + lbi <- getPersistBuildConfig distPref + (exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs + + maybeWithSandboxDirOnSearchPath useSandbox $ + build verbosity config' distPref buildFlags ["exe:" ++ display (exeName exe)] + + maybeWithSandboxDirOnSearchPath useSandbox $ + run verbosity lbi exe exeArgs + +getAction :: GetFlags -> [String] -> Action +getAction getFlags extraArgs globalFlags = do + let verbosity = fromFlag (getVerbosity getFlags) + targets <- readUserTargets verbosity extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + withRepoContext verbosity (savedGlobalFlags config) $ \repoContext -> + get verbosity + repoContext + globalFlags' + getFlags + targets + +unpackAction :: GetFlags -> [String] -> Action +unpackAction getFlags extraArgs globalFlags = do + getAction getFlags extraArgs globalFlags + +initAction :: InitFlags -> [String] -> Action +initAction initFlags extraArgs globalFlags = do + let verbosity = fromFlag (initVerbosity initFlags) + when (extraArgs /= []) $ + die' verbosity $ "'init' doesn't take any extra arguments: " ++ unwords extraArgs + (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity + (globalFlags { globalRequireSandbox = Flag False }) + let configFlags = savedConfigureFlags config + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, _, progdb) <- configCompilerAux' configFlags + withRepoContext verbosity globalFlags' $ \repoContext -> + initCabal verbosity + (configPackageDB' configFlags) + repoContext + comp + progdb + initFlags + +sandboxAction :: SandboxFlags -> [String] -> Action +sandboxAction sandboxFlags extraArgs globalFlags = do + let verbosity = fromFlag (sandboxVerbosity sandboxFlags) + case extraArgs of + -- Basic sandbox commands. + ["init"] -> sandboxInit verbosity sandboxFlags globalFlags + ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags + ("add-source":extra) -> do + when (noExtraArgs extra) $ + die' verbosity "The 'sandbox add-source' command expects at least one argument" + sandboxAddSource verbosity extra sandboxFlags globalFlags + ("delete-source":extra) -> do + when (noExtraArgs extra) $ + die' verbosity ("The 'sandbox delete-source' command expects " ++ + "at least one argument") + sandboxDeleteSource verbosity extra sandboxFlags globalFlags + ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags + + -- More advanced commands. + ("hc-pkg":extra) -> do + when (noExtraArgs extra) $ + die' verbosity $ "The 'sandbox hc-pkg' command expects at least one argument" + sandboxHcPkg verbosity sandboxFlags globalFlags extra + ["buildopts"] -> die' verbosity "Not implemented!" + + -- Hidden commands. + ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags + + -- Error handling. + [] -> die' verbosity $ "Please specify a subcommand (see 'help sandbox')" + _ -> die' verbosity $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs + + where + noExtraArgs = (<1) . length + +execAction :: ExecFlags -> [String] -> Action +execAction execFlags extraArgs globalFlags = do + let verbosity = fromFlag (execVerbosity execFlags) + (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags + distPref <- findSavedDistPref config (execDistPref execFlags) + let configFlags = savedConfigureFlags config + configFlags' = configFlags { configDistPref = Flag distPref } + (comp, platform, progdb) <- getPersistOrConfigCompiler configFlags' + exec verbosity useSandbox comp platform progdb extraArgs + +userConfigAction :: UserConfigFlags -> [String] -> Action +userConfigAction ucflags extraArgs globalFlags = do + let verbosity = fromFlag (userConfigVerbosity ucflags) + force = fromFlag (userConfigForce ucflags) + extraLines = fromFlag (userConfigAppendLines ucflags) + case extraArgs of + ("init":_) -> do + path <- configFile + fileExists <- doesFileExist path + if (not fileExists || (fileExists && force)) + then void $ createDefaultConfigFile verbosity extraLines path + else die' verbosity $ path ++ " already exists." + ("diff":_) -> mapM_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines + ("update":_) -> userConfigUpdate verbosity globalFlags extraLines + -- Error handling. + [] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')" + _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs + where configFile = getConfigFilePath (globalConfigFile globalFlags) + +-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. +-- +win32SelfUpgradeAction :: Win32SelfUpgradeFlags -> [String] -> Action +win32SelfUpgradeAction selfUpgradeFlags (pid:path:_extraArgs) _globalFlags = do + let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags) + Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path -- TODO: eradicateNoParse +win32SelfUpgradeAction _ _ _ = return () + +-- | Used as an entry point when cabal-install needs to invoke itself +-- as a setup script. This can happen e.g. when doing parallel builds. +-- +actAsSetupAction :: ActAsSetupFlags -> [String] -> Action +actAsSetupAction actAsSetupFlags args _globalFlags = + let bt = fromFlag (actAsSetupBuildType actAsSetupFlags) + in case bt of + Simple -> Simple.defaultMainArgs args + Configure -> Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks args + Make -> Make.defaultMainArgs args + Custom -> error "actAsSetupAction Custom" + +manpageAction :: [CommandSpec action] -> Flag Verbosity -> [String] -> Action +manpageAction commands flagVerbosity extraArgs _ = do + let verbosity = fromFlag flagVerbosity + unless (null extraArgs) $ + die' verbosity $ "'manpage' doesn't take any extra arguments: " ++ unwords extraArgs + pname <- getProgName + let cabalCmd = if takeExtension pname == ".exe" + then dropExtension pname + else pname + putStrLn $ manpage cabalCmd commands diff --git a/tests/IntegrationTests2.hs b/tests/IntegrationTests2.hs --- a/tests/IntegrationTests2.hs +++ b/tests/IntegrationTests2.hs @@ -18,7 +18,8 @@ import Distribution.Client.ProjectOrchestration ( resolveTargets, TargetProblemCommon(..), distinctTargetComponents ) import Distribution.Client.Types - ( PackageLocation(..), UnresolvedSourcePackage ) + ( PackageLocation(..), UnresolvedSourcePackage + , PackageSpecifier(..) ) import Distribution.Client.Targets ( UserConstraint(..), UserConstraintScope(UserAnyQualifier) ) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -148,7 +149,7 @@ reportSubCase "cwd" do Right ts <- readTargetSelectors' [] - ts @?= [TargetPackage TargetImplicitCwd "p-0.1" Nothing] + ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing] reportSubCase "all" do Right ts <- readTargetSelectors' @@ -163,7 +164,7 @@ , "tests", ":cwd:tests" , "benchmarks", ":cwd:benchmarks"] zipWithM_ (@?=) ts - [ TargetPackage TargetImplicitCwd "p-0.1" (Just kind) + [ TargetPackage TargetImplicitCwd ["p-0.1"] (Just kind) | kind <- concatMap (replicate 2) [LibKind .. ] ] @@ -199,10 +200,10 @@ , "q:tests", "q/:tests", ":pkg:q:tests" , "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"] zipWithM_ (@?=) ts $ - [ TargetPackage TargetExplicitNamed "p-0.1" (Just kind) + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just kind) | kind <- concatMap (replicate 3) [LibKind .. ] ] ++ - [ TargetPackage TargetExplicitNamed "q-0.1" (Just kind) + [ TargetPackage TargetExplicitNamed ["q-0.1"] (Just kind) | kind <- concatMap (replicate 3) [LibKind .. ] ] @@ -288,19 +289,19 @@ reportSubCase "ambiguous: cwd-pkg filter vs pkg" assertAmbiguous "libs" [ mkTargetPackage "libs" - , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just LibKind) ] + , TargetPackage TargetImplicitCwd ["libs"] (Just LibKind) ] [mkpkg "libs" []] reportSubCase "ambiguous: filter vs cwd component" assertAmbiguous "exes" [ mkTargetComponent "other" (CExeName "exes") - , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just ExeKind) ] + , TargetPackage TargetImplicitCwd ["other"] (Just ExeKind) ] [mkpkg "other" [mkexe "exes"]] -- but filters are not ambiguous with non-cwd components, modules or files reportSubCase "unambiguous: filter vs non-cwd comp, mod, file" assertUnambiguous "Libs" - (TargetPackage TargetImplicitCwd "bar" (Just LibKind)) + (TargetPackage TargetImplicitCwd ["bar"] (Just LibKind)) [ mkpkgAt "foo" [mkexe "Libs"] "foo" , mkpkg "bar" [ mkexe "bar" `withModules` ["Libs"] , mkexe "baz" `withCFiles` ["Libs"] ] @@ -366,11 +367,14 @@ ] where assertAmbiguous :: String - -> [TargetSelector PackageId] + -> [TargetSelector] -> [SourcePackage (PackageLocation a)] -> Assertion assertAmbiguous str tss pkgs = do - res <- readTargetSelectorsWith fakeDirActions pkgs [str] + res <- readTargetSelectorsWith + fakeDirActions + (map SpecificSourcePackage pkgs) + [str] case res of Left [TargetSelectorAmbiguous _ tss'] -> sort (map snd tss') @?= sort tss @@ -378,11 +382,14 @@ ++ "got " ++ show res assertUnambiguous :: String - -> TargetSelector PackageId + -> TargetSelector -> [SourcePackage (PackageLocation a)] -> Assertion assertUnambiguous str ts pkgs = do - res <- readTargetSelectorsWith fakeDirActions pkgs [str] + res <- readTargetSelectorsWith + fakeDirActions + (map SpecificSourcePackage pkgs) + [str] case res of Right [ts'] -> ts' @?= ts _ -> assertFailure $ "expected Right [Target...], " @@ -432,23 +439,23 @@ exe { buildInfo = (buildInfo exe) { cSources = files } } -mkTargetPackage :: PackageId -> TargetSelector PackageId +mkTargetPackage :: PackageId -> TargetSelector mkTargetPackage pkgid = - TargetPackage TargetExplicitNamed pkgid Nothing + TargetPackage TargetExplicitNamed [pkgid] Nothing -mkTargetComponent :: PackageId -> ComponentName -> TargetSelector PackageId +mkTargetComponent :: PackageId -> ComponentName -> TargetSelector mkTargetComponent pkgid cname = TargetComponent pkgid cname WholeComponent -mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector PackageId +mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector mkTargetModule pkgid cname mname = TargetComponent pkgid cname (ModuleTarget mname) -mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector PackageId +mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector mkTargetFile pkgid cname fname = TargetComponent pkgid cname (FileTarget fname) -mkTargetAllPackages :: TargetSelector PackageId +mkTargetAllPackages :: TargetSelector mkTargetAllPackages = TargetAllPackages Nothing instance IsString PackageIdentifier where @@ -509,8 +516,8 @@ [ (packageName p, packageId p) | p <- InstallPlan.toList elaboratedPlan ] - cases :: [( TargetSelector PackageId -> CmdBuild.TargetProblem - , TargetSelector PackageId + cases :: [( TargetSelector -> CmdBuild.TargetProblem + , TargetSelector )] cases = [ -- Cannot resolve packages outside of the project @@ -666,8 +673,8 @@ CmdBuild.selectPackageTargets CmdBuild.selectComponentTarget CmdBuild.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) - , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") @@ -719,7 +726,7 @@ , AvailableTarget "p-0.1" (CTestName "p1") (TargetBuildable () TargetNotRequestedByDefault) True ] - , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ) ] reportSubCase "multiple targets" @@ -789,7 +796,7 @@ CmdRepl.selectPackageTargets CmdRepl.selectComponentTarget CmdRepl.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" Nothing ] + [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] [ ("p-0.1-inplace", CLibName) ] -- When we select the package with an explicit filter then we get those -- components even though we did not explicitly enable tests/benchmarks @@ -798,14 +805,14 @@ CmdRepl.selectPackageTargets CmdRepl.selectComponentTarget CmdRepl.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ] + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ] [ ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] assertProjectDistinctTargets elaboratedPlan CmdRepl.selectPackageTargets CmdRepl.selectComponentTarget CmdRepl.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) ] + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ] @@ -862,45 +869,16 @@ [ ( CmdRun.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) ] - reportSubCase "test-only" + reportSubCase "lib-only" assertProjectTargetProblems - "targets/test-only" config + "targets/lib-only" config CmdRun.selectPackageTargets CmdRun.selectComponentTarget CmdRun.TargetProblemCommon [ ( CmdRun.TargetProblemNoExes, mkTargetPackage "p-0.1" ) ] - reportSubCase "variety" - assertProjectTargetProblems - "targets/variety" config - CmdRun.selectPackageTargets - CmdRun.selectComponentTarget - CmdRun.TargetProblemCommon $ - [ ( const (CmdRun.TargetProblemComponentNotExe "p-0.1" cname) - , mkTargetComponent "p-0.1" cname ) - | cname <- [ CLibName, CFLibName "libp", - CTestName "a-testsuite", CBenchName "a-benchmark" ] - ] ++ - [ ( const (CmdRun.TargetProblemIsSubComponent - "p-0.1" cname (ModuleTarget modname)) - , mkTargetModule "p-0.1" cname modname ) - | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") - , (CBenchName "a-benchmark", "BenchModule") - , (CExeName "an-exe", "ExeModule") - , (CLibName, "P") - ] - ] ++ - [ ( const (CmdRun.TargetProblemIsSubComponent - "p-0.1" cname (FileTarget fname)) - , mkTargetFile "p-0.1" cname fname) - | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") - , (CBenchName "a-benchmark", "Bench.hs") - , (CExeName "an-exe", "Main.hs") - ] - ] - testTargetProblemsTest :: ProjectConfig -> (String -> IO ()) -> Assertion testTargetProblemsTest config reportSubCase = do @@ -1188,10 +1166,10 @@ (CmdHaddock.selectPackageTargets haddockFlags) CmdHaddock.selectComponentTarget CmdHaddock.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" (Just FLibKind) - , TargetPackage TargetExplicitNamed "p-0.1" (Just ExeKind) - , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) - , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just FLibKind) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just ExeKind) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") @@ -1210,10 +1188,10 @@ assertProjectDistinctTargets :: forall err. (Eq err, Show err) => ElaboratedInstallPlan - -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k]) - -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) + -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) + -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) - -> [TargetSelector PackageId] + -> [TargetSelector] -> [(UnitId, ComponentName)] -> Assertion assertProjectDistinctTargets elaboratedPlan @@ -1240,14 +1218,14 @@ assertProjectTargetProblems :: forall err. (Eq err, Show err) => FilePath -> ProjectConfig - -> (forall k. TargetSelector PackageId + -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) - -> (forall k. PackageId -> ComponentName -> SubComponentTarget + -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) - -> [(TargetSelector PackageId -> err, TargetSelector PackageId)] + -> [(TargetSelector -> err, TargetSelector)] -> Assertion assertProjectTargetProblems testdir config selectPackageTargets @@ -1266,10 +1244,10 @@ assertTargetProblems :: forall err. (Eq err, Show err) => ElaboratedInstallPlan - -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k]) - -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) + -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) + -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) - -> [(TargetSelector PackageId -> err, TargetSelector PackageId)] + -> [(TargetSelector -> err, TargetSelector)] -> Assertion assertTargetProblems elaboratedPlan selectPackageTargets @@ -1369,14 +1347,16 @@ marker1 @?= "ok" removeFile (basedir testdir1 "marker") - reportSubCase (show SetupCustomImplicitDeps) - (plan2, res2) <- executePlan =<< planProject testdir2 config - (pkg2, _) <- expectPackageInstalled plan2 res2 pkgidA - elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps - hasDefaultSetupDeps pkg2 @?= Just True - marker2 <- readFile (basedir testdir2 "marker") - marker2 @?= "ok" - removeFile (basedir testdir2 "marker") + -- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later + when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8,2]) $ do + reportSubCase (show SetupCustomImplicitDeps) + (plan2, res2) <- executePlan =<< planProject testdir2 config + (pkg2, _) <- expectPackageInstalled plan2 res2 pkgidA + elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps + hasDefaultSetupDeps pkg2 @?= Just True + marker2 <- readFile (basedir testdir2 "marker") + marker2 @?= "ok" + removeFile (basedir testdir2 "marker") reportSubCase (show SetupNonCustomInternalLib) (plan3, res3) <- executePlan =<< planProject testdir3 config @@ -1478,7 +1458,7 @@ type ProjDetails = (DistDirLayout, CabalDirLayout, ProjectConfig, - [UnresolvedSourcePackage], + [PackageSpecifier UnresolvedSourcePackage], BuildTimeSettings) configureProject :: FilePath -> ProjectConfig -> IO ProjDetails diff --git a/tests/IntegrationTests2/targets/lib-only/p.cabal b/tests/IntegrationTests2/targets/lib-only/p.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/targets/lib-only/p.cabal @@ -0,0 +1,8 @@ +name: p +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: P + build-depends: base diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -9,7 +9,7 @@ import Distribution.Compat.Time -import qualified UnitTests.Distribution.Solver.Modular.PSQ +import qualified UnitTests.Distribution.Solver.Modular.Builder import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ import qualified UnitTests.Distribution.Solver.Modular.Solver import qualified UnitTests.Distribution.Solver.Modular.RetryLog @@ -38,8 +38,8 @@ else mtimeChangeCalibrated in testGroup "Unit Tests" - [ testGroup "UnitTests.Distribution.Solver.Modular.PSQ" - UnitTests.Distribution.Solver.Modular.PSQ.tests + [ testGroup "UnitTests.Distribution.Solver.Modular.Builder" + UnitTests.Distribution.Solver.Modular.Builder.tests , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ" UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests , testGroup "UnitTests.Distribution.Solver.Modular.Solver" diff --git a/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/tests/UnitTests/Distribution/Client/ProjectConfig.hs --- a/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -16,6 +16,7 @@ import Distribution.Compiler import Distribution.Version import Distribution.ParseUtils +import Distribution.Text as Text import Distribution.Simple.Compiler import Distribution.Simple.Setup import Distribution.Simple.InstallDirs @@ -63,6 +64,9 @@ , testGroup "individual parser tests" [ testProperty "package location" prop_parsePackageLocationTokenQ + , testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep + , testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps + , testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps' ] , testGroup "ProjectConfig printing/parsing round trip" @@ -200,11 +204,12 @@ hackProjectConfigShared config = config { projectConfigProjectFile = mempty, -- not present within project files + projectConfigConfigFile = mempty, -- ditto projectConfigConstraints = --TODO: [required eventually] parse ambiguity in constraint -- "pkgname -any" as either any version or disabled flag "any". let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) = - (not . null) [ () | (name, False) <- flags + (not . null) [ () | (name, False) <- unFlagAssignment flags , "any" `isPrefixOf` unFlagName name ] ambiguous _ = False in filter (not . ambiguous) (projectConfigConstraints config) @@ -228,17 +233,42 @@ ---------------------------- --- Individual Parser tests +-- Individual Parser tests -- +-- | Helper to parse a given string +-- +-- Succeeds only if there is a unique complete parse +runReadP :: Parse.ReadP a a -> String -> Maybe a +runReadP parser s = case [ x | (x,"") <- Parse.readP_to_S parser s ] of + [x'] -> Just x' + _ -> Nothing + prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool prop_parsePackageLocationTokenQ (PackageLocationString str) = - case [ x | (x,"") <- Parse.readP_to_S parsePackageLocationTokenQ - (renderPackageLocationToken str) ] of - [str'] -> str' == str - _ -> False + runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str +prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Bool +prop_roundtrip_printparse_RelaxedDep rdep = + runReadP Text.parse (Text.display rdep) == Just rdep +prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Bool +prop_roundtrip_printparse_RelaxDeps rdep = + runReadP Text.parse (Text.display rdep) == Just rdep + +prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Bool +prop_roundtrip_printparse_RelaxDeps' rdep = + runReadP Text.parse (go $ Text.display rdep) == Just rdep + where + -- replace 'all' tokens by '*' + go :: String -> String + go [] = [] + go "all" = "*" + go ('a':'l':'l':c:rest) | c `elem` ":," = '*' : go (c:rest) + go rest = let (x,y) = break (`elem` ":,") rest + (x',y') = span (`elem` ":,^") y + in x++x'++go y' + ------------------------ -- Arbitrary instances -- @@ -254,17 +284,36 @@ <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> (MapMappend . fmap getNonMEmpty . Map.fromList <$> shortListOf 3 arbitrary) -- package entries with no content are equivalent to -- the entry not existing at all, so exclude empty - shrink (ProjectConfig x0 x1 x2 x3 x4 x5 x6 x7 x8) = - [ ProjectConfig x0' x1' x2' x3' - x4' x5' x6' x7' (MapMappend (fmap getNonMEmpty x8')) - | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8')) + shrink ProjectConfig { projectPackages = x0 + , projectPackagesOptional = x1 + , projectPackagesRepo = x2 + , projectPackagesNamed = x3 + , projectConfigBuildOnly = x4 + , projectConfigShared = x5 + , projectConfigProvenance = x6 + , projectConfigLocalPackages = x7 + , projectConfigSpecificPackage = x8 + , projectConfigAllPackages = x9 } = + [ ProjectConfig { projectPackages = x0' + , projectPackagesOptional = x1' + , projectPackagesRepo = x2' + , projectPackagesNamed = x3' + , projectConfigBuildOnly = x4' + , projectConfigShared = x5' + , projectConfigProvenance = x6' + , projectConfigLocalPackages = x7' + , projectConfigSpecificPackage = (MapMappend + (fmap getNonMEmpty x8')) + , projectConfigAllPackages = x9' } + | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9')) <- shrink ((x0, x1, x2, x3), - (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8))) + (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9)) ] newtype PackageLocationString @@ -370,6 +419,7 @@ ProjectConfigShared <$> arbitraryFlag arbitraryShortToken <*> arbitraryFlag arbitraryShortToken + <*> arbitraryFlag arbitraryShortToken <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitraryFlag arbitraryShortToken @@ -385,44 +435,87 @@ <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary + <*> (toNubList <$> listOf arbitraryShortToken) where arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] arbitraryConstraints = - map (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary + fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary - shrink (ProjectConfigShared - x00 x01 x02 x03 x04 - x05 x06 x07 x08 x09 - x10 x11 x12 x13 x14 - x15 x16 x17 x18 x19 - x20) = - [ ProjectConfigShared - x00' x01' x02' (fmap getNonEmpty x03') (fmap getNonEmpty x04') - x05' x06' x07' x08' (postShrink_Constraints x09') - x10' x11' x12' x13' x14' x15' x16' x17' x18' x19' x20' + shrink ProjectConfigShared { projectConfigDistDir = x00 + , projectConfigProjectFile = x01 + , projectConfigHcFlavor = x02 + , projectConfigHcPath = x03 + , projectConfigHcPkg = x04 + , projectConfigHaddockIndex = x05 + , projectConfigRemoteRepos = x06 + , projectConfigLocalRepos = x07 + , projectConfigIndexState = x08 + , projectConfigConstraints = x09 + , projectConfigPreferences = x10 + , projectConfigCabalVersion = x11 + , projectConfigSolver = x12 + , projectConfigAllowOlder = x13 + , projectConfigAllowNewer = x14 + , projectConfigMaxBackjumps = x15 + , projectConfigReorderGoals = x16 + , projectConfigCountConflicts = x17 + , projectConfigStrongFlags = x18 + , projectConfigAllowBootLibInstalls = x19 + , projectConfigPerComponent = x20 + , projectConfigIndependentGoals = x21 + , projectConfigConfigFile = x22 + , projectConfigProgPathExtra = x23} = + [ ProjectConfigShared { projectConfigDistDir = x00' + , projectConfigProjectFile = x01' + , projectConfigHcFlavor = x02' + , projectConfigHcPath = fmap getNonEmpty x03' + , projectConfigHcPkg = fmap getNonEmpty x04' + , projectConfigHaddockIndex = x05' + , projectConfigRemoteRepos = x06' + , projectConfigLocalRepos = x07' + , projectConfigIndexState = x08' + , projectConfigConstraints = postShrink_Constraints x09' + , projectConfigPreferences = x10' + , projectConfigCabalVersion = x11' + , projectConfigSolver = x12' + , projectConfigAllowOlder = x13' + , projectConfigAllowNewer = x14' + , projectConfigMaxBackjumps = x15' + , projectConfigReorderGoals = x16' + , projectConfigCountConflicts = x17' + , projectConfigStrongFlags = x18' + , projectConfigAllowBootLibInstalls = x19' + , projectConfigPerComponent = x20' + , projectConfigIndependentGoals = x21' + , projectConfigConfigFile = x22' + , projectConfigProgPathExtra = x23'} | ((x00', x01', x02', x03', x04'), (x05', x06', x07', x08', x09'), (x10', x11', x12', x13', x14'), (x15', x16', x17', x18', x19'), - x20') + x20', x21', x22', x23') <- shrink ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04), (x05, x06, x07, x08, preShrink_Constraints x09), (x10, x11, x12, x13, x14), (x15, x16, x17, x18, x19), - x20) + x20, x21, x22, x23) ] where preShrink_Constraints = map fst postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource)) projectConfigConstraintSource :: ConstraintSource -projectConfigConstraintSource = +projectConfigConstraintSource = ConstraintSourceProjectConfig "TODO" instance Arbitrary ProjectConfigProvenance where arbitrary = elements [Implicit, Explicit "cabal.project"] +instance Arbitrary FlagAssignment where + arbitrary = mkFlagAssignment <$> arbitrary + instance Arbitrary PackageConfig where arbitrary = PackageConfig @@ -434,7 +527,7 @@ <*> listOf arbitraryShortToken)) <*> (toNubList <$> listOf arbitraryShortToken) <*> arbitrary - <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary @@ -444,13 +537,13 @@ <*> shortListOf 5 arbitraryShortToken <*> shortListOf 5 arbitraryShortToken <*> shortListOf 5 arbitraryShortToken - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitrary <*> arbitrary @@ -460,59 +553,125 @@ <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitrary + <*> arbitrary where arbitraryProgramName :: Gen String arbitraryProgramName = elements [ programName prog | (prog, _) <- knownPrograms (defaultProgramDb) ] - shrink (PackageConfig - x00 x01 x02 x03 x04 - x05 x06 x07 x08 x09 - x10 x11 x12 x13 x14 - x15 x16 x17 x18 x19 - x20 x21 x22 x23 x24 - x25 x26 x27 x28 x29 - x30 x31 x32 x33 x33_1 x34 - x35 x36 x37 x38 x39 - x40) = - [ PackageConfig - (postShrink_Paths x00') - (postShrink_Args x01') x02' x03' x04' - x05' x06' x07' x08' x09' - x10' x11' (map getNonEmpty x12') x13' x14' - x15' (map getNonEmpty x16') - (map getNonEmpty x17') - (map getNonEmpty x18') - x19' - x20' x21' x22' x23' x24' - x25' x26' x27' x28' x29' - x30' x31' x32' x33' x33_1' x34' - x35' x36' (fmap getNonEmpty x37') x38' - (fmap getNonEmpty x39') - x40' - | (((x00', x01', x02', x03', x04'), - (x05', x06', x07', x08', x09'), + shrink PackageConfig { packageConfigProgramPaths = x00 + , packageConfigProgramArgs = x01 + , packageConfigProgramPathExtra = x02 + , packageConfigFlagAssignment = x03 + , packageConfigVanillaLib = x04 + , packageConfigSharedLib = x05 + , packageConfigStaticLib = x42 + , packageConfigDynExe = x06 + , packageConfigProf = x07 + , packageConfigProfLib = x08 + , packageConfigProfExe = x09 + , packageConfigProfDetail = x10 + , packageConfigProfLibDetail = x11 + , packageConfigConfigureArgs = x12 + , packageConfigOptimization = x13 + , packageConfigProgPrefix = x14 + , packageConfigProgSuffix = x15 + , packageConfigExtraLibDirs = x16 + , packageConfigExtraFrameworkDirs = x17 + , packageConfigExtraIncludeDirs = x18 + , packageConfigGHCiLib = x19 + , packageConfigSplitSections = x20 + , packageConfigSplitObjs = x20_1 + , packageConfigStripExes = x21 + , packageConfigStripLibs = x22 + , packageConfigTests = x23 + , packageConfigBenchmarks = x24 + , packageConfigCoverage = x25 + , packageConfigRelocatable = x26 + , packageConfigDebugInfo = x27 + , packageConfigRunTests = x28 + , packageConfigDocumentation = x29 + , packageConfigHaddockHoogle = x30 + , packageConfigHaddockHtml = x31 + , packageConfigHaddockHtmlLocation = x32 + , packageConfigHaddockForeignLibs = x33 + , packageConfigHaddockExecutables = x33_1 + , packageConfigHaddockTestSuites = x34 + , packageConfigHaddockBenchmarks = x35 + , packageConfigHaddockInternal = x36 + , packageConfigHaddockCss = x37 + , packageConfigHaddockLinkedSource = x38 + , packageConfigHaddockHscolourCss = x39 + , packageConfigHaddockContents = x40 + , packageConfigHaddockForHackage = x41 } = + [ PackageConfig { packageConfigProgramPaths = postShrink_Paths x00' + , packageConfigProgramArgs = postShrink_Args x01' + , packageConfigProgramPathExtra = x02' + , packageConfigFlagAssignment = x03' + , packageConfigVanillaLib = x04' + , packageConfigSharedLib = x05' + , packageConfigStaticLib = x42' + , packageConfigDynExe = x06' + , packageConfigProf = x07' + , packageConfigProfLib = x08' + , packageConfigProfExe = x09' + , packageConfigProfDetail = x10' + , packageConfigProfLibDetail = x11' + , packageConfigConfigureArgs = map getNonEmpty x12' + , packageConfigOptimization = x13' + , packageConfigProgPrefix = x14' + , packageConfigProgSuffix = x15' + , packageConfigExtraLibDirs = map getNonEmpty x16' + , packageConfigExtraFrameworkDirs = map getNonEmpty x17' + , packageConfigExtraIncludeDirs = map getNonEmpty x18' + , packageConfigGHCiLib = x19' + , packageConfigSplitSections = x20' + , packageConfigSplitObjs = x20_1' + , packageConfigStripExes = x21' + , packageConfigStripLibs = x22' + , packageConfigTests = x23' + , packageConfigBenchmarks = x24' + , packageConfigCoverage = x25' + , packageConfigRelocatable = x26' + , packageConfigDebugInfo = x27' + , packageConfigRunTests = x28' + , packageConfigDocumentation = x29' + , packageConfigHaddockHoogle = x30' + , packageConfigHaddockHtml = x31' + , packageConfigHaddockHtmlLocation = x32' + , packageConfigHaddockForeignLibs = x33' + , packageConfigHaddockExecutables = x33_1' + , packageConfigHaddockTestSuites = x34' + , packageConfigHaddockBenchmarks = x35' + , packageConfigHaddockInternal = x36' + , packageConfigHaddockCss = fmap getNonEmpty x37' + , packageConfigHaddockLinkedSource = x38' + , packageConfigHaddockHscolourCss = fmap getNonEmpty x39' + , packageConfigHaddockContents = x40' + , packageConfigHaddockForHackage = x41' } + | (((x00', x01', x02', x03', x04'), + (x05', x42', x06', x07', x08', x09'), (x10', x11', x12', x13', x14'), (x15', x16', x17', x18', x19')), - ((x20', x21', x22', x23', x24'), + ((x20', x20_1', x21', x22', x23', x24'), (x25', x26', x27', x28', x29'), (x30', x31', x32', (x33', x33_1'), x34'), (x35', x36', x37', x38', x39'), - (x40'))) + (x40', x41'))) <- shrink - (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04), - (x05, x06, x07, x08, x09), - (x10, x11, map NonEmpty x12, x13, x14), - (x15, map NonEmpty x16, - map NonEmpty x17, - map NonEmpty x18, - x19)), - ((x20, x21, x22, x23, x24), + (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04), + (x05, x42, x06, x07, x08, x09), + (x10, x11, map NonEmpty x12, x13, x14), + (x15, map NonEmpty x16, + map NonEmpty x17, + map NonEmpty x18, + x19)), + ((x20, x20_1, x21, x22, x23, x24), (x25, x26, x27, x28, x29), (x30, x31, x32, (x33, x33_1), x34), (x35, x36, fmap NonEmpty x37, x38, fmap NonEmpty x39), - (x40))) + (x40, x41))) ] where preShrink_Paths = Map.map NonEmpty @@ -528,6 +687,8 @@ . Map.map (map getNonEmpty . getNonEmpty) . Map.mapKeys getNoShrink +instance Arbitrary HaddockTarget where + arbitrary = elements [ForHackage, ForDevelopment] instance Arbitrary SourceRepo where arbitrary = (SourceRepo RepoThis @@ -620,7 +781,7 @@ arbitrary = oneof [ PackagePropertyVersion <$> arbitrary , pure PackagePropertyInstalled , pure PackagePropertySource - , PackagePropertyFlags <$> shortListOf1 3 arbitrary + , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary , PackagePropertyStanzas . (\x->[x]) <$> arbitrary ] @@ -643,6 +804,9 @@ instance Arbitrary CountConflicts where arbitrary = CountConflicts <$> arbitrary +instance Arbitrary IndependentGoals where + arbitrary = IndependentGoals <$> arbitrary + instance Arbitrary StrongFlags where arbitrary = StrongFlags <$> arbitrary @@ -656,16 +820,28 @@ arbitrary = AllowOlder <$> arbitrary instance Arbitrary RelaxDeps where - arbitrary = oneof [ pure RelaxDepsNone + arbitrary = oneof [ pure mempty , RelaxDepsSome <$> shortListOf1 3 arbitrary , pure RelaxDepsAll ] -instance Arbitrary RelaxedDep where - arbitrary = oneof [ RelaxedDep <$> arbitrary - , RelaxedDepScoped <$> arbitrary <*> arbitrary +instance Arbitrary RelaxDepMod where + arbitrary = elements [RelaxDepModNone, RelaxDepModCaret] + +instance Arbitrary RelaxDepScope where + arbitrary = oneof [ pure RelaxDepScopeAll + , RelaxDepScopePackage <$> arbitrary + , RelaxDepScopePackageId <$> (PackageIdentifier <$> arbitrary <*> arbitrary) ] +instance Arbitrary RelaxDepSubject where + arbitrary = oneof [ pure RelaxDepSubjectAll + , RelaxDepSubjectPkg <$> arbitrary + ] + +instance Arbitrary RelaxedDep where + arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary + instance Arbitrary ProfDetailLevel where arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] @@ -696,4 +872,3 @@ arbitraryURIPort :: Gen String arbitraryURIPort = oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ] - diff --git a/tests/UnitTests/Distribution/Client/Store.hs b/tests/UnitTests/Distribution/Client/Store.hs --- a/tests/UnitTests/Distribution/Client/Store.hs +++ b/tests/UnitTests/Distribution/Client/Store.hs @@ -51,7 +51,7 @@ let destprefix = dir "prefix" createDirectory destprefix writeFile (destprefix file) content - return destprefix + return (destprefix,[]) assertNewStoreEntry tmp storeDirLayout compid unitid1 (copyFiles "file1" "content-foo") (return ()) @@ -137,7 +137,7 @@ assertNewStoreEntry :: FilePath -> StoreDirLayout -> CompilerId -> UnitId - -> (FilePath -> IO FilePath) -> IO () + -> (FilePath -> IO (FilePath,[FilePath])) -> IO () -> NewStoreEntryOutcome -> Assertion assertNewStoreEntry tmp storeDirLayout compid unitid diff --git a/tests/UnitTests/Distribution/Client/Tar.hs b/tests/UnitTests/Distribution/Client/Tar.hs --- a/tests/UnitTests/Distribution/Client/Tar.hs +++ b/tests/UnitTests/Distribution/Client/Tar.hs @@ -32,7 +32,7 @@ e2 = getFileEntry "file2" "y" p = (\e -> let (NormalFile dta _) = entryContent e str = BS.Char8.unpack dta - in not . (=="y") $ str) + in str /= "y") assertEqual "Unexpected result for filter" "xz" $ entriesToString $ filterEntries p $ Next e1 $ Next e2 Done assertEqual "Unexpected result for filter" "z" $ @@ -46,7 +46,7 @@ e2 = getFileEntry "file2" "y" p = (\e -> let (NormalFile dta _) = entryContent e str = BS.Char8.unpack dta - in tell "t" >> return (not . (=="y") $ str)) + in tell "t" >> return (str /= "y")) (r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done assertEqual "Unexpected result for filterM" "xz" $ entriesToString r diff --git a/tests/UnitTests/Distribution/Client/Targets.hs b/tests/UnitTests/Distribution/Client/Targets.hs --- a/tests/UnitTests/Distribution/Client/Targets.hs +++ b/tests/UnitTests/Distribution/Client/Targets.hs @@ -7,7 +7,7 @@ ,UserConstraint(..), readUserConstraint) import Distribution.Compat.ReadP (readP_to_S) import Distribution.Package (mkPackageName) -import Distribution.PackageDescription (mkFlagName) +import Distribution.PackageDescription (mkFlagName, mkFlagAssignment) import Distribution.Version (anyVersion, thisVersion, mkVersion) import Distribution.ParseUtils (parseCommaList) import Distribution.Text (parse) @@ -31,10 +31,10 @@ tests = [ makeGroup "readUserConstraint" (uncurry readUserConstraintTest) exampleConstraints - + , makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest) exampleConstraints - + , makeGroup "readUserConstraints" (uncurry readUserConstraintsTest) [-- First example only. (head exampleStrs, take 1 exampleUcs), @@ -49,7 +49,7 @@ [ ("template-haskell installed", UserConstraint (UserQualified UserQualToplevel (pn "template-haskell")) PackagePropertyInstalled) - + , ("bytestring -any", UserConstraint (UserQualified UserQualToplevel (pn "bytestring")) (PackagePropertyVersion anyVersion)) @@ -65,13 +65,14 @@ , ("process:setup.bytestring ==5.2", UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring")) (PackagePropertyVersion (thisVersion (mkVersion [5, 2])))) - + , ("network:setup.containers +foo -bar baz", UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers")) - (PackagePropertyFlags [(fn "foo", True), + (PackagePropertyFlags (mkFlagAssignment + [(fn "foo", True), (fn "bar", False), - (fn "baz", True)])) - + (fn "baz", True)]))) + -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. -- -- , ("foo:happy:exe.template-haskell test", diff --git a/tests/UnitTests/Distribution/Client/UserConfig.hs b/tests/UnitTests/Distribution/Client/UserConfig.hs --- a/tests/UnitTests/Distribution/Client/UserConfig.hs +++ b/tests/UnitTests/Distribution/Client/UserConfig.hs @@ -37,7 +37,7 @@ -- Create a new default config file in our test directory. _ <- loadConfig silent (Flag configFile) -- Now we read it in and compare it against the default. - diff <- userConfigDiff $ globalFlags configFile + diff <- userConfigDiff silent (globalFlags configFile) [] assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff @@ -46,7 +46,7 @@ -- Create a new default config file in our test directory. _ <- loadConfig silent (Flag configFile) appendFile configFile "verbose: 0\n" - diff <- userConfigDiff $ globalFlags configFile + diff <- userConfigDiff silent (globalFlags configFile) [] assertBool (unlines $ "Should detect a difference:" : diff) $ diff == [ "+ verbose: 0" ] @@ -56,7 +56,7 @@ -- Write a trivial cabal file. writeFile configFile "tests: True\n" -- Update the config file. - userConfigUpdate silent $ globalFlags configFile + userConfigUpdate silent (globalFlags configFile) [] -- Load it again. updated <- loadConfig silent (Flag configFile) assertBool ("Field 'tests' should be True") $ @@ -68,7 +68,7 @@ -- Create a new default config file in our test directory. _ <- loadConfig silent (Flag configFile) -- Update it twice. - replicateM_ 2 . userConfigUpdate silent $ globalFlags configFile + replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) [] -- Load it again. updated <- loadConfig silent (Flag configFile) @@ -85,7 +85,7 @@ sysTmpDir <- getTemporaryDirectory withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do let configFile = tmpDir "tmp.config" - _ <- createDefaultConfigFile silent configFile + _ <- createDefaultConfigFile silent [] configFile exists <- doesFileExist configFile assertBool ("Config file should be written to " ++ configFile) exists diff --git a/tests/UnitTests/Distribution/Solver/Modular/Builder.hs b/tests/UnitTests/Distribution/Solver/Modular/Builder.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/Builder.hs @@ -0,0 +1,20 @@ +module UnitTests.Distribution.Solver.Modular.Builder ( + tests + ) where + +import Distribution.Solver.Modular.Builder + +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: [TestTree] +tests = [ testProperty "splitsAltImplementation" splitsTest + ] + +-- | Simpler splits implementation +splits' :: [a] -> [(a, [a])] +splits' [] = [] +splits' (x : xs) = (x, xs) : map (\ (y, ys) -> (y, x : ys)) (splits' xs) + +splitsTest :: [Int] -> Property +splitsTest xs = splits' xs === splits xs diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL.hs --- a/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -32,16 +32,15 @@ , withExe , withExes , runProgress + , mkSimpleVersion , mkVersionRange ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Solver.Compat.Prelude -- base import Data.Either (partitionEithers) -import Data.List (elemIndex) -import Data.Ord (comparing) import qualified Data.Map as Map -- Cabal @@ -51,6 +50,7 @@ import qualified Distribution.ModuleName as Module import qualified Distribution.Package as C hiding (HasUnitId(..)) +import qualified Distribution.Types.ExeDependency as C import qualified Distribution.Types.LegacyExeDependency as C import qualified Distribution.Types.PkgconfigDependency as C import qualified Distribution.Types.UnqualComponentName as C @@ -149,12 +149,18 @@ -- and an exclusive upper bound. | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion - -- | Build-tools dependency - | ExBuildToolAny ExamplePkgName + -- | Build-tool-depends dependency + | ExBuildToolAny ExamplePkgName ExampleExeName - -- | Build-tools dependency on a fixed version - | ExBuildToolFix ExamplePkgName ExamplePkgVersion + -- | Build-tool-depends dependency on a fixed version + | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion + -- | Legacy build-tools dependency + | ExLegacyBuildToolAny ExamplePkgName + + -- | Legacy build-tools dependency on a fixed version + | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion + -- | Dependencies indexed by a flag | ExFlagged ExampleFlagName Dependencies Dependencies @@ -187,10 +193,13 @@ data ExConstraint = ExVersionConstraint ConstraintScope ExampleVersionRange | ExFlagConstraint ConstraintScope ExampleFlagName Bool + | ExStanzaConstraint ConstraintScope [OptionalStanza] + deriving Show data ExPreference = ExPkgPref ExamplePkgName ExampleVersionRange | ExStanzaPref ExamplePkgName [OptionalStanza] + deriving Show data ExampleAvailable = ExAv { exAvName :: ExamplePkgName @@ -208,11 +217,18 @@ | S ExampleQualifier ExamplePkgName OptionalStanza data ExampleQualifier = - None - | Indep Int - | Setup ExamplePkgName - | IndepSetup Int ExamplePkgName + QualNone + | QualIndep ExamplePkgName + | QualSetup ExamplePkgName + -- The two package names are the build target and the package containing the + -- setup script. + | QualIndepSetup ExamplePkgName ExamplePkgName + + -- The two package names are the package depending on the exe and the + -- package containing the exe. + | QualExe ExamplePkgName ExamplePkgName + -- | Whether to enable tests in all packages in a test case. newtype EnableAllTests = EnableAllTests Bool deriving BooleanFlag @@ -333,10 +349,10 @@ C.packageDescription = C.emptyPackageDescription { C.package = pkgId , C.setupBuildInfo = setup - , C.license = BSD3 - , C.buildType = if isNothing setup - then Just C.Simple - else Just C.Custom + , C.licenseRaw = Right BSD3 + , C.buildTypeRaw = if isNothing setup + then Just C.Simple + else Just C.Custom , C.category = "category" , C.maintainer = "maintainer" , C.description = "description" @@ -395,37 +411,46 @@ , [Extension] , Maybe Language , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config - , [(ExamplePkgName, C.VersionRange)] -- build tools + , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools + , [(ExamplePkgName, C.VersionRange)] -- legacy build tools ) splitTopLevel [] = - ([], [], Nothing, [], []) - splitTopLevel (ExBuildToolAny p:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, C.anyVersion):exes) - splitTopLevel (ExBuildToolFix p v:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, C.thisVersion (mkVersion v)):exes) + ([], [], Nothing, [], [], []) + splitTopLevel (ExBuildToolAny p e:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes) + splitTopLevel (ExBuildToolFix p e v:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes) + splitTopLevel (ExLegacyBuildToolAny p:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes) + splitTopLevel (ExLegacyBuildToolFix p v:deps) = + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes) splitTopLevel (ExExt ext:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (other, ext:exts, lang, pcpkgs, exes) + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, ext:exts, lang, pcpkgs, exes, legacyExes) splitTopLevel (ExLang lang:deps) = case splitTopLevel deps of - (other, exts, Nothing, pcpkgs, exes) -> (other, exts, Just lang, pcpkgs, exes) + (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes) _ -> error "Only 1 Language dependency is supported" splitTopLevel (ExPkg pkg:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (other, exts, lang, pkg:pcpkgs, exes) + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (other, exts, lang, pkg:pcpkgs, exes, legacyExes) splitTopLevel (dep:deps) = - let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps - in (dep:other, exts, lang, pcpkgs, exes) + let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps + in (dep:other, exts, lang, pcpkgs, exes, legacyExes) -- Extract the total set of flags used extractFlags :: ExampleDependency -> [ExampleFlagName] extractFlags (ExAny _) = [] extractFlags (ExFix _ _) = [] extractFlags (ExRange _ _ _) = [] - extractFlags (ExBuildToolAny _) = [] - extractFlags (ExBuildToolFix _ _) = [] + extractFlags (ExBuildToolAny _ _) = [] + extractFlags (ExBuildToolFix _ _ _) = [] + extractFlags (ExLegacyBuildToolAny _) = [] + extractFlags (ExLegacyBuildToolFix _ _) = [] extractFlags (ExFlagged f a b) = f : concatMap extractFlags (deps a ++ deps b) where @@ -467,17 +492,19 @@ , C.condTreeComponents = [] } mkBuildInfoTree (Buildable deps) = - let (libraryDeps, exts, mlang, pcpkgs, buildTools) = splitTopLevel deps + let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel deps (directDeps, flaggedDeps) = splitDeps libraryDeps bi = mempty { C.otherExtensions = exts , C.defaultLanguage = mlang + , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr + | (p, e, vr) <- buildTools] , C.buildTools = [ C.LegacyExeDependency n vr - | (n,vr) <- buildTools ] + | (n,vr) <- legacyBuildTools] , C.pkgconfigDepends = [ C.PkgconfigDependency n' v' | (n,v) <- pcpkgs , let n' = C.mkPkgconfigName n - , let v' = C.thisVersion (mkVersion v) ] + , let v' = C.thisVersion (mkSimpleVersion v) ] } in C.CondNode { C.condTreeData = bi -- Necessary for language extensions @@ -514,7 +541,7 @@ in ((p, C.anyVersion):directDeps, flaggedDeps) splitDeps (ExFix p v:deps) = let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.thisVersion $ mkVersion v):directDeps, flaggedDeps) + in ((p, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) splitDeps (ExRange p v1 v2:deps) = let (directDeps, flaggedDeps) = splitDeps deps in ((p, mkVersionRange v1 v2):directDeps, flaggedDeps) @@ -528,13 +555,13 @@ mkSetupDeps deps = let (directDeps, []) = splitDeps deps in map mkDirect directDeps -mkVersion :: ExamplePkgVersion -> C.Version -mkVersion n = C.mkVersion [n, 0, 0] +mkSimpleVersion :: ExamplePkgVersion -> C.Version +mkSimpleVersion n = C.mkVersion [n, 0, 0] mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange mkVersionRange v1 v2 = - C.intersectVersionRanges (C.orLaterVersion $ mkVersion v1) - (C.earlierVersion $ mkVersion v2) + C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1) + (C.earlierVersion $ mkSimpleVersion v2) mkFlag :: ExFlag -> C.Flag mkFlag flag = C.MkFlag { @@ -587,20 +614,22 @@ -> Maybe [Language] -> PC.PkgConfigDb -> [ExamplePkgName] - -> Solver -> Maybe Int + -> CountConflicts -> IndependentGoals -> ReorderGoals -> AllowBootLibInstalls -> EnableBackjumping - -> Maybe [ExampleVar] + -> SolveExecutables + -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) -> [ExConstraint] -> [ExPreference] -> EnableAllTests -> Progress String String CI.SolverInstallPlan.SolverInstallPlan -exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder - allowBootLibInstalls enableBj vars constraints prefs enableAllTests - = resolveDependencies C.buildPlatform compiler pkgConfigDb solver params +exResolve db exts langs pkgConfigDb targets mbj countConflicts indepGoals + reorder allowBootLibInstalls enableBj solveExes goalOrder constraints + prefs enableAllTests + = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params where defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag compiler = defaultCompiler { C.compilerInfoExtensions = exts @@ -622,11 +651,13 @@ params = addConstraints (fmap toConstraint constraints) $ addConstraints (fmap toLpc enableTests) $ addPreferences (fmap toPref prefs) + $ setCountConflicts countConflicts $ setIndependentGoals indepGoals $ setReorderGoals reorder $ setMaxBackjumps mbj $ setAllowBootLibInstalls allowBootLibInstalls $ setEnableBackjumping enableBj + $ setSolveExecutables solveExes $ setGoalOrder goalOrder $ standardInstallPolicy instIdx avaiIdx targets' toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown @@ -634,33 +665,12 @@ toConstraint (ExVersionConstraint scope v) = toLpc $ PackageConstraint scope (PackagePropertyVersion v) toConstraint (ExFlagConstraint scope fn b) = - toLpc $ PackageConstraint scope (PackagePropertyFlags [(C.mkFlagName fn, b)]) + toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)])) + toConstraint (ExStanzaConstraint scope stanzas) = + toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas) toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas - - goalOrder :: Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) - goalOrder = (orderFromList . map toVariable) `fmap` vars - - -- Sort elements in the list ahead of elements not in the list. Otherwise, - -- follow the order in the list. - orderFromList :: Eq a => [a] -> a -> a -> Ordering - orderFromList xs = - comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) - - toVariable :: ExampleVar -> Variable P.QPN - toVariable (P q pn) = PackageVar (toQPN q pn) - toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn) - toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza - - toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN - toQPN q pn = P.Q pp (C.mkPackageName pn) - where - pp = case q of - None -> P.PackagePath P.DefaultNamespace P.QualToplevel - Indep x -> P.PackagePath (P.Independent x) P.QualToplevel - Setup p -> P.PackagePath P.DefaultNamespace (P.QualSetup (C.mkPackageName p)) - IndepSetup x p -> P.PackagePath (P.Independent x) (P.QualSetup (C.mkPackageName p)) extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan -> [(ExamplePkgName, ExamplePkgVersion)] diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs --- a/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -3,9 +3,11 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils ( SolverTest , SolverResult(..) + , maxBackjumps , independentGoals , allowBootLibInstalls , disableBackjumping + , disableSolveExecutables , goalOrder , constraints , preferences @@ -21,22 +23,33 @@ , runTest ) where +import Prelude () +import Distribution.Solver.Compat.Prelude + +import Data.List (elemIndex) +import Data.Ord (comparing) + -- test-framework import Test.Tasty as TF import Test.Tasty.HUnit (testCase, assertEqual, assertBool) -- Cabal +import qualified Distribution.PackageDescription as C +import qualified Distribution.Types.PackageName as C import Language.Haskell.Extension (Extension(..), Language(..)) -- cabal-install +import qualified Distribution.Solver.Types.PackagePath as P import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList) import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Variable import Distribution.Client.Dependency (foldProgress) -import Distribution.Client.Dependency.Types - ( Solver(Modular) ) import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Options +maxBackjumps :: Maybe Int -> SolverTest -> SolverTest +maxBackjumps mbj test = test { testMaxBackjumps = mbj } + -- | Combinator to turn on --independent-goals behavior, i.e. solve -- for the goals as if we were solving for each goal independently. independentGoals :: SolverTest -> SolverTest @@ -50,6 +63,10 @@ disableBackjumping test = test { testEnableBackjumping = EnableBackjumping False } +disableSolveExecutables :: SolverTest -> SolverTest +disableSolveExecutables test = + test { testSolveExecutables = SolveExecutables False } + goalOrder :: [ExampleVar] -> SolverTest -> SolverTest goalOrder order test = test { testGoalOrder = Just order } @@ -67,20 +84,22 @@ -------------------------------------------------------------------------------} data SolverTest = SolverTest { - testLabel :: String - , testTargets :: [String] - , testResult :: SolverResult - , testIndepGoals :: IndependentGoals + testLabel :: String + , testTargets :: [String] + , testResult :: SolverResult + , testMaxBackjumps :: Maybe Int + , testIndepGoals :: IndependentGoals , testAllowBootLibInstalls :: AllowBootLibInstalls - , testEnableBackjumping :: EnableBackjumping - , testGoalOrder :: Maybe [ExampleVar] - , testConstraints :: [ExConstraint] - , testSoftConstraints :: [ExPreference] - , testDb :: ExampleDb - , testSupportedExts :: Maybe [Extension] - , testSupportedLangs :: Maybe [Language] - , testPkgConfigDb :: PkgConfigDb - , testEnableAllTests :: EnableAllTests + , testEnableBackjumping :: EnableBackjumping + , testSolveExecutables :: SolveExecutables + , testGoalOrder :: Maybe [ExampleVar] + , testConstraints :: [ExConstraint] + , testSoftConstraints :: [ExPreference] + , testDb :: ExampleDb + , testSupportedExts :: Maybe [Extension] + , testSupportedLangs :: Maybe [Language] + , testPkgConfigDb :: PkgConfigDb + , testEnableAllTests :: EnableAllTests } -- | Expected result of a solver test. @@ -158,20 +177,22 @@ -> SolverResult -> SolverTest mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest { - testLabel = label - , testTargets = targets - , testResult = result - , testIndepGoals = IndependentGoals False + testLabel = label + , testTargets = targets + , testResult = result + , testMaxBackjumps = Nothing + , testIndepGoals = IndependentGoals False , testAllowBootLibInstalls = AllowBootLibInstalls False - , testEnableBackjumping = EnableBackjumping True - , testGoalOrder = Nothing - , testConstraints = [] - , testSoftConstraints = [] - , testDb = db - , testSupportedExts = exts - , testSupportedLangs = langs - , testPkgConfigDb = pkgConfigDbFromList pkgConfigDb - , testEnableAllTests = EnableAllTests False + , testEnableBackjumping = EnableBackjumping True + , testSolveExecutables = SolveExecutables True + , testGoalOrder = Nothing + , testConstraints = [] + , testSoftConstraints = [] + , testDb = db + , testSupportedExts = exts + , testSupportedLangs = langs + , testPkgConfigDb = pkgConfigDbFromList pkgConfigDb + , testEnableAllTests = EnableAllTests False } runTest :: SolverTest -> TF.TestTree @@ -179,12 +200,12 @@ testCase testLabel $ do let progress = exResolve testDb testSupportedExts testSupportedLangs testPkgConfigDb testTargets - Modular Nothing testIndepGoals (ReorderGoals False) - testAllowBootLibInstalls testEnableBackjumping testGoalOrder - testConstraints testSoftConstraints testEnableAllTests - printMsg msg = if showSolverLog - then putStrLn msg - else return () + testMaxBackjumps (CountConflicts True) testIndepGoals + (ReorderGoals False) testAllowBootLibInstalls + testEnableBackjumping testSolveExecutables + (sortGoals <$> testGoalOrder) testConstraints + testSoftConstraints testEnableAllTests + printMsg msg = when showSolverLog $ putStrLn msg msgs = foldProgress (:) (const []) (const []) progress assertBool ("Unexpected solver log:\n" ++ unlines msgs) $ resultLogPredicate testResult $ concatMap lines msgs @@ -202,3 +223,32 @@ case resultErrorMsgPredicateOrPlan result of Left f -> f msg Right _ -> False + + sortGoals :: [ExampleVar] + -> Variable P.QPN -> Variable P.QPN -> Ordering + sortGoals = orderFromList . map toVariable + + -- Sort elements in the list ahead of elements not in the list. Otherwise, + -- follow the order in the list. + orderFromList :: Eq a => [a] -> a -> a -> Ordering + orderFromList xs = + comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) + + toVariable :: ExampleVar -> Variable P.QPN + toVariable (P q pn) = PackageVar (toQPN q pn) + toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn) + toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza + + toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN + toQPN q pn = P.Q pp (C.mkPackageName pn) + where + pp = case q of + QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel + QualIndep p -> P.PackagePath (P.Independent $ C.mkPackageName p) + P.QualToplevel + QualSetup s -> P.PackagePath P.DefaultNamespace + (P.QualSetup (C.mkPackageName s)) + QualIndepSetup p s -> P.PackagePath (P.Independent $ C.mkPackageName p) + (P.QualSetup (C.mkPackageName s)) + QualExe p1 p2 -> P.PackagePath P.DefaultNamespace + (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) diff --git a/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs b/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs --- a/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs @@ -11,6 +11,8 @@ runTest $ basicTest "basic space leak test" , runTest $ flagsTest "package with many flags" , runTest $ issue2899 "issue #2899" + , runTest $ duplicateDependencies "duplicate dependencies" + , runTest $ duplicateFlaggedDependencies "duplicate flagged dependencies" ] -- | This test solves for n packages that each have two versions. There is no @@ -49,17 +51,14 @@ pkgs :: ExampleDb pkgs = [Right $ exAv "pkg" 1 $ - [exFlagged (flagName n) [ExAny "unknown1"] [ExAny "unknown2"]] + [exFlagged (numberedFlag n) [ExAny "unknown1"] [ExAny "unknown2"]] -- The remaining flags have no effect: - ++ [exFlagged (flagName i) [] [] | i <- [1..n - 1]] + ++ [exFlagged (numberedFlag i) [] [] | i <- [1..n - 1]] ] - flagName :: Int -> ExampleFlagName - flagName x = "flag-" ++ show x - orderedFlags :: [ExampleVar] - orderedFlags = [F None "pkg" (flagName i) | i <- [1..n]] + orderedFlags = [F QualNone "pkg" (numberedFlag i) | i <- [1..n]] -- | Test for a space leak caused by sharing of search trees under packages with -- link choices (issue #2899). @@ -94,4 +93,99 @@ pkgName x = "pkg-" ++ show x goals :: [ExampleVar] - goals = [P None "setup-dep", P (Setup "target") "setup-dep"] + goals = [P QualNone "setup-dep", P (QualSetup "target") "setup-dep"] + +-- | Test for an issue related to lifting dependencies out of conditionals when +-- converting a PackageDescription to the solver's internal representation. +-- +-- Issue: +-- For each conditional and each package B, the solver combined each dependency +-- on B in the true branch with each dependency on B in the false branch. It +-- added the combined dependencies to the build-depends outside of the +-- conditional. Since dependencies could be lifted out of multiple levels of +-- conditionals, the number of new dependencies could grow exponentially in the +-- number of levels. For example, the following package generated 4 copies of B +-- under flag-2=False, 8 copies under flag-1=False, and 16 copies at the top +-- level: +-- +-- if flag(flag-1) +-- build-depends: B, B +-- else +-- if flag(flag-2) +-- build-depends: B, B +-- else +-- if flag(flag-3) +-- build-depends: B, B +-- else +-- build-depends: B, B +-- +-- This issue caused the quickcheck tests to start frequently running out of +-- memory after an optimization that pruned unreachable branches (See PR #4929). +-- Each problematic test case contained at least one build-depends field with +-- duplicate dependencies, which was then duplicated under multiple levels of +-- conditionals by the solver's "buildable: False" transformation, when +-- "buildable: False" was under multiple flags. Finally, the branch pruning +-- feature put all build-depends fields in consecutive levels of the condition +-- tree, causing the solver's representation of the package to follow the +-- pattern in the example above. +-- +-- Now the solver avoids this issue by combining all dependencies on the same +-- package before lifting them out of conditionals. +-- +-- This test case is an expanded version of the example above, with library and +-- build-tool dependencies. +duplicateDependencies :: String -> SolverTest +duplicateDependencies name = + mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)] + where + copies, depth :: Int + copies = 50 + depth = 50 + + pkgs :: ExampleDb + pkgs = [ + Right $ exAv "A" 1 (dependencyTree 1) + , Right $ exAv "B" 1 [] `withExe` ExExe "exe" [] + ] + + dependencyTree :: Int -> [ExampleDependency] + dependencyTree n + | n > depth = buildDepends + | otherwise = [exFlagged (numberedFlag n) buildDepends + (dependencyTree (n + 1))] + where + buildDepends = replicate copies (ExFix "B" 1) + ++ replicate copies (ExBuildToolFix "B" "exe" 1) + +-- | This test is similar to duplicateDependencies, except that every dependency +-- on B is replaced by a conditional that contains B in both branches. It tests +-- that the solver doesn't just combine dependencies within one build-depends or +-- build-tool-depends field; it also needs to combine dependencies after they +-- are lifted out of conditionals. +duplicateFlaggedDependencies :: String -> SolverTest +duplicateFlaggedDependencies name = + mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)] + where + copies, depth :: Int + copies = 15 + depth = 15 + + pkgs :: ExampleDb + pkgs = [ + Right $ exAv "A" 1 (dependencyTree 1) + , Right $ exAv "B" 1 [] `withExe` ExExe "exe" [] + ] + + dependencyTree :: Int -> [ExampleDependency] + dependencyTree n + | n > depth = flaggedDeps + | otherwise = [exFlagged (numberedFlag n) flaggedDeps + (dependencyTree (n + 1))] + where + flaggedDeps = zipWith ($) (replicate copies flaggedDep) [0 :: Int ..] + flaggedDep m = exFlagged (numberedFlag n ++ "-" ++ show m) buildDepends + buildDepends + buildDepends = [ExFix "B" 1, ExBuildToolFix "B" "exe" 1] + +numberedFlag :: Int -> ExampleFlagName +numberedFlag n = "flag-" ++ show n diff --git a/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs b/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/PSQ.hs +++ /dev/null @@ -1,22 +0,0 @@ -module UnitTests.Distribution.Solver.Modular.PSQ ( - tests - ) where - -import Distribution.Solver.Modular.PSQ - -import Test.Tasty -import Test.Tasty.QuickCheck - -tests :: [TestTree] -tests = [ testProperty "splitsAltImplementation" splitsTest - ] - --- | Original splits implementation -splits' :: PSQ k a -> PSQ k (a, PSQ k a) -splits' xs = - casePSQ xs - (PSQ []) - (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys))) - -splitsTest :: [(Int, Int)] -> Bool -splitsTest psq = splits' (PSQ psq) == splits (PSQ psq) diff --git a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs --- a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -1,41 +1,49 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where -import Control.DeepSeq (NFData, force) -import Control.Monad (foldM) +import Prelude () +import Distribution.Client.Compat.Prelude + +import Control.Arrow ((&&&)) +import Control.DeepSeq (force) import Data.Either (lefts) import Data.Function (on) -import Data.List (groupBy, isInfixOf, nub, nubBy, sort) -import Data.Maybe (isJust) -import GHC.Generics (Generic) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>)) -import Data.Monoid (Monoid) -#endif +import Data.Hashable (Hashable(..)) +import Data.List (groupBy, isInfixOf) +import Data.Ord (comparing) import Text.Show.Pretty (parseValue, valToStr) import Test.Tasty (TestTree) import Test.Tasty.QuickCheck -import Distribution.Client.Dependency.Types - ( Solver(..) ) +import Distribution.Types.GenericPackageDescription (FlagName) +import Distribution.Utils.ShortText (ShortText) + import Distribution.Client.Setup (defaultMaxBackjumps) +import Distribution.Types.PackageName import Distribution.Types.UnqualComponentName import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps ( Component(..), ComponentDep, ComponentDeps ) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint +import qualified Distribution.Solver.Types.PackagePath as P import Distribution.Solver.Types.PkgConfigDb (pkgConfigDbFromList) import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Variable +import Distribution.Version import UnitTests.Distribution.Solver.Modular.DSL +import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils + ( testPropertyWithSeed ) tests :: [TestTree] tests = [ @@ -43,12 +51,15 @@ -- existence of a solution. It runs the solver twice, and only sets those -- parameters on the second run. The test also applies parameters that -- can affect the existence of a solution to both runs. - testProperty "target order and --reorder-goals do not affect solvability" $ - \(SolverTest db targets) targetOrder reorderGoals indepGoals solver -> - let r1 = solve' (ReorderGoals False) targets db - r2 = solve' reorderGoals targets2 db - solve' reorder = solve (EnableBackjumping True) reorder - indepGoals solver + testPropertyWithSeed "target and goal order do not affect solvability" $ + \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals -> + let r1 = solve' mGoalOrder1 test + r2 = solve' mGoalOrder2 test { testTargets = targets2 } + solve' goalOrder = + solve (EnableBackjumping True) (ReorderGoals False) + (CountConflicts True) indepGoals + (getBlind <$> goalOrder) + targets = testTargets test targets2 = case targetOrder of SameOrder -> targets ReverseOrder -> reverse targets @@ -56,25 +67,44 @@ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) - , testProperty + , testPropertyWithSeed "solvable without --independent-goals => solvable with --independent-goals" $ - \(SolverTest db targets) reorderGoals solver -> - let r1 = solve' (IndependentGoals False) targets db - r2 = solve' (IndependentGoals True) targets db - solve' indep = solve (EnableBackjumping True) - reorderGoals indep solver + \test reorderGoals -> + let r1 = solve' (IndependentGoals False) test + r2 = solve' (IndependentGoals True) test + solve' indep = solve (EnableBackjumping True) reorderGoals + (CountConflicts True) indep Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) `implies` isRight (resultPlan r2) - , testProperty "backjumping does not affect solvability" $ - \(SolverTest db targets) reorderGoals indepGoals -> - let r1 = solve' (EnableBackjumping True) targets db - r2 = solve' (EnableBackjumping False) targets db - solve' enableBj = solve enableBj reorderGoals indepGoals Modular + , testPropertyWithSeed "backjumping does not affect solvability" $ + \test reorderGoals indepGoals -> + let r1 = solve' (EnableBackjumping True) test + r2 = solve' (EnableBackjumping False) test + solve' enableBj = solve enableBj reorderGoals + (CountConflicts True) indepGoals Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) + + -- This test uses --no-count-conflicts, because the goal order used with + -- --count-conflicts depends on the total set of conflicts seen by the + -- solver. The solver explores more of the tree and encounters more + -- conflicts when it doesn't backjump. The different goal orders can lead to + -- different solutions and cause the test to fail. + -- TODO: Find a faster way to randomly sort goals, and then use a random + -- goal order in this test. + , testPropertyWithSeed + "backjumping does not affect the result (with static goal order)" $ + \test reorderGoals indepGoals -> + let r1 = solve' (EnableBackjumping True) test + r2 = solve' (EnableBackjumping False) test + solve' enableBj = solve enableBj reorderGoals + (CountConflicts False) indepGoals Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + resultPlan r1 === resultPlan r2 ] where noneReachedBackjumpLimit :: [Result] -> Bool @@ -97,19 +127,25 @@ isRight (Right _) = True isRight _ = False -solve :: EnableBackjumping -> ReorderGoals -> IndependentGoals - -> Solver -> [PN] -> TestDb -> Result -solve enableBj reorder indep solver targets (TestDb db) = +newtype VarOrdering = VarOrdering { + unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering + } + +solve :: EnableBackjumping -> ReorderGoals -> CountConflicts -> IndependentGoals + -> Maybe VarOrdering + -> SolverTest -> Result +solve enableBj reorder countConflicts indep goalOrder test = let (lg, result) = - runProgress $ exResolve db Nothing Nothing + runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing (pkgConfigDbFromList []) - (map unPN targets) - solver + (map unPN (testTargets test)) -- The backjump limit prevents individual tests from using -- too much time and memory. (Just defaultMaxBackjumps) - indep reorder (AllowBootLibInstalls False) enableBj Nothing [] [] - (EnableAllTests True) + countConflicts indep reorder (AllowBootLibInstalls False) + enableBj (SolveExecutables True) (unVarOrdering <$> goalOrder) + (testConstraints test) (testPreferences test) + (EnableAllTests False) failure :: String -> Failure failure msg @@ -168,26 +204,40 @@ data SolverTest = SolverTest { testDb :: TestDb , testTargets :: [PN] + , testConstraints :: [ExConstraint] + , testPreferences :: [ExPreference] } -- | Pretty-print the test when quickcheck calls 'show'. instance Show SolverTest where show test = let str = "SolverTest {testDb = " ++ show (testDb test) - ++ ", testTargets = " ++ show (testTargets test) ++ "}" + ++ ", testTargets = " ++ show (testTargets test) + ++ ", testConstraints = " ++ show (testConstraints test) + ++ ", testPreferences = " ++ show (testPreferences test) + ++ "}" in maybe str valToStr $ parseValue str instance Arbitrary SolverTest where arbitrary = do db <- arbitrary - let pkgs = nub $ map getName (unTestDb db) + let pkgVersions = nub $ map (getName &&& getVersion) (unTestDb db) + pkgs = nub $ map fst pkgVersions Positive n <- arbitrary targets <- randomSubset n pkgs - return (SolverTest db targets) + constraints <- case pkgVersions of + [] -> return [] + _ -> boundedListOf 1 $ arbitraryConstraint pkgVersions + prefs <- case pkgVersions of + [] -> return [] + _ -> boundedListOf 3 $ arbitraryPreference pkgVersions + return (SolverTest db targets constraints prefs) shrink test = [test { testDb = db } | db <- shrink (testDb test)] ++ [test { testTargets = targets } | targets <- shrink (testTargets test)] + ++ [test { testConstraints = cs } | cs <- shrink (testConstraints test)] + ++ [test { testPreferences = prefs } | prefs <- shrink (testPreferences test)] -- | Collection of source and installed packages. newtype TestDb = TestDb { unTestDb :: ExampleDb } @@ -203,7 +253,7 @@ TestDb <$> shuffle (unTestDb db) where nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb - nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> mapM (nextPkg db) pkgs + nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> traverse (nextPkg db) pkgs nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage nextPkg db (pn, v) = do @@ -220,10 +270,10 @@ arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled arbitraryExInst pn v pkgs = do - hash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] + pkgHash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] numDeps <- min 3 <$> arbitrary deps <- randomSubset numDeps pkgs - return $ ExInst (unPN pn) (unPV v) hash (map exInstHash deps) + return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps) arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency]) arbitraryComponentDeps (TestDb []) = return $ CD.fromList [] @@ -288,6 +338,34 @@ arbitraryFlagName :: Gen String arbitraryFlagName = (:[]) <$> elements ['A'..'E'] +arbitraryConstraint :: [(PN, PV)] -> Gen ExConstraint +arbitraryConstraint pkgs = do + (PN pn, v) <- elements pkgs + let anyQualifier = ScopeAnyQualifier (mkPackageName pn) + oneof [ + ExVersionConstraint anyQualifier <$> arbitraryVersionRange v + , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas] + ] + +arbitraryPreference :: [(PN, PV)] -> Gen ExPreference +arbitraryPreference pkgs = do + (PN pn, v) <- elements pkgs + oneof [ + ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas] + , ExPkgPref pn <$> arbitraryVersionRange v + ] + +arbitraryVersionRange :: PV -> Gen VersionRange +arbitraryVersionRange (PV v) = + let version = mkSimpleVersion v + in elements [ + thisVersion version + , notThisVersion version + , earlierVersion version + , orLaterVersion version + , noVersion + ] + instance Arbitrary ReorderGoals where arbitrary = ReorderGoals <$> arbitrary @@ -298,11 +376,6 @@ shrink (IndependentGoals indep) = [IndependentGoals False | indep] -instance Arbitrary Solver where - arbitrary = return Modular - - shrink Modular = [] - instance Arbitrary UnqualComponentName where arbitrary = mkUnqualComponentName <$> (:[]) <$> elements "ABC" @@ -355,6 +428,56 @@ shrink NotBuildable = [Buildable []] shrink (Buildable deps) = map Buildable (shrink deps) + +instance Arbitrary ExConstraint where + arbitrary = error "arbitrary not implemented: ExConstraint" + + shrink (ExStanzaConstraint scope stanzas) = + [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas] + shrink (ExVersionConstraint scope vr) = + [ExVersionConstraint scope vr' | vr' <- shrink vr] + shrink _ = [] + +instance Arbitrary ExPreference where + arbitrary = error "arbitrary not implemented: ExPreference" + + shrink (ExStanzaPref pn stanzas) = + [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas] + shrink (ExPkgPref pn vr) = [ExPkgPref pn vr' | vr' <- shrink vr] + +instance Arbitrary OptionalStanza where + arbitrary = error "arbitrary not implemented: OptionalStanza" + + shrink BenchStanzas = [TestStanzas] + shrink TestStanzas = [] + +instance Arbitrary VersionRange where + arbitrary = error "arbitrary not implemented: VersionRange" + + shrink vr = [noVersion | vr /= noVersion] + +-- Randomly sorts solver variables using 'hash'. +-- TODO: Sorting goals with this function is very slow. +instance Arbitrary VarOrdering where + arbitrary = do + f <- arbitrary :: Gen (Int -> Int) + return $ VarOrdering (comparing (f . hash)) + +instance Hashable pn => Hashable (Variable pn) +instance Hashable a => Hashable (P.Qualified a) +instance Hashable P.PackagePath +instance Hashable P.Qualifier +instance Hashable P.Namespace +instance Hashable OptionalStanza +instance Hashable FlagName +instance Hashable PackageName +instance Hashable ShortText + +deriving instance Generic (Variable pn) +deriving instance Generic (P.Qualified a) +deriving instance Generic P.PackagePath +deriving instance Generic P.Namespace +deriving instance Generic P.Qualifier randomSubset :: Int -> [a] -> Gen [a] randomSubset n xs = take n <$> shuffle xs diff --git a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs @@ -0,0 +1,33 @@ +module UnitTests.Distribution.Solver.Modular.QuickCheck.Utils ( + testPropertyWithSeed + ) where + +import Data.Tagged (Tagged, retag) +import System.Random (getStdRandom, random) + +import Test.Tasty (TestTree) +import Test.Tasty.Options (OptionDescription, lookupOption, setOption) +import Test.Tasty.Providers (IsTest (..), singleTest) +import Test.Tasty.QuickCheck + ( QC (..), QuickCheckReplay (..), Testable, property ) + +import Distribution.Simple.Utils +import Distribution.Verbosity + +-- | Create a QuickCheck test that prints the seed before testing the property. +-- The seed can be useful for debugging non-terminating test cases. This is +-- related to https://github.com/feuerbach/tasty/issues/86. +testPropertyWithSeed :: Testable a => String -> a -> TestTree +testPropertyWithSeed name = singleTest name . QCWithSeed . QC . property + +newtype QCWithSeed = QCWithSeed QC + +instance IsTest QCWithSeed where + testOptions = retag (testOptions :: Tagged QC [OptionDescription]) + + run options (QCWithSeed test) progress = do + replay <- case lookupOption options of + QuickCheckReplay (Just override) -> return override + QuickCheckReplay Nothing -> getStdRandom random + notice normal $ "Using --quickcheck-replay=" ++ show replay + run (setOption (QuickCheckReplay (Just replay)) options) test progress diff --git a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs --- a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -21,7 +21,7 @@ import Distribution.Solver.Types.Flag import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.PackagePath +import qualified Distribution.Solver.Types.PackagePath as P import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils @@ -51,12 +51,17 @@ , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)]) ] + , testGroup "Lifting dependencies out of conditionals" [ + runTest $ commonDependencyLogMessage "common dependency log message" + , runTest $ twoLevelDeepCommonDependencyLogMessage "two level deep common dependency log message" + , runTest $ testBackjumpingWithCommonDependency "backjumping with common dependency" + ] , testGroup "Manual flags" [ runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $ solverSuccess [("pkg", 1), ("true-dep", 1)] , let checkFullLog = - any $ isInfixOf "rejecting: pkg-1.0.0:-flag (manual flag can only be changed explicitly)" + any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)" in runTest $ constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $ mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $ -- TODO: We should check the summarized log instead of the full log @@ -71,39 +76,39 @@ ] , testGroup "Qualified manual flag constraints" [ let name = "Top-level flag constraint does not constrain setup dep's flag" - cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False] + cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ solverSuccess [ ("A", 1), ("B", 1), ("B", 2) , ("b-1-false-dep", 1), ("b-2-true-dep", 1) ] , let name = "Solver can toggle setup dep's flag to match top-level constraint" - cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False + cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ] in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ solverSuccess [ ("A", 1), ("B", 1), ("B", 2) , ("b-1-false-dep", 1), ("b-2-false-dep", 1) ] , let name = "User can constrain flags separately with qualified constraints" - cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ] + cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True + , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ] in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ solverSuccess [ ("A", 1), ("B", 1), ("B", 2) , ("b-1-true-dep", 1), ("b-2-false-dep", 1) ] -- Regression test for #4299 , let name = "Solver can link deps when only one has constrained manual flag" - cs = [ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" False] + cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ] , let name = "Solver cannot link deps that have conflicting manual flag constraints" - cs = [ ExFlagConstraint (ScopeQualified QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (QualSetup "A") "B") "flag" False ] + cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True + , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ] failureReason = "(constraint from unknown source requires opposite flag selection)" checkFullLog lns = all (\msg -> any (msg `isInfixOf`) lns) - [ "rejecting: B-1.0.0:-flag " ++ failureReason - , "rejecting: A:setup.B-1.0.0:+flag " ++ failureReason ] + [ "rejecting: B:-flag " ++ failureReason + , "rejecting: A:setup.B:+flag " ++ failureReason ] in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ SolverResult checkFullLog (Left $ const True) @@ -118,6 +123,7 @@ , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)]) , runTest $ enableAllTests $ mkTest db6 "depsWithTests1" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) + , runTest $ testTestSuiteWithFlag "test suite with flag" ] , testGroup "Setup dependencies" [ runTest $ mkTest db7 "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)]) @@ -153,6 +159,7 @@ , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (solverSuccess [("C", 2), ("D", 1)]) , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (solverSuccess [("D", 1)]) , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (solverSuccess [("C", 2), ("D", 1), ("E", 1)]) + , runTest $ issue4161 "detect cycle between package and its setup script" , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages" ] , testGroup "Extensions" [ @@ -179,8 +186,8 @@ mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $ solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] - , let cs = [ ExVersionConstraint (ScopeQualified QualToplevel "D") $ mkVersionRange 1 4 - , ExVersionConstraint (ScopeQualified (QualSetup "B") "D") $ mkVersionRange 4 7 + , let cs = [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4 + , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7 ] in runTest $ constraints cs $ mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $ @@ -215,6 +222,8 @@ , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $ mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $ solverSuccess [("pkg", 1)] + + , testStanzaPreference "test stanza preference" ] , testGroup "Buildable Field" [ testBuildable "avoid building component with unknown dependency" (ExAny "unknown") @@ -252,15 +261,74 @@ , runTest $ mkTest dbBJ7 "bj7" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) , runTest $ indep $ mkTest dbBJ8 "bj8" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) ] - -- Build-tools dependencies - , testGroup "build-tools" [ - runTest $ mkTest dbBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)]) - , runTest $ mkTest dbBuildTools2 "bt2" ["A"] (solverSuccess [("A", 1)]) - , runTest $ mkTest dbBuildTools3 "bt3" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)]) - , runTest $ mkTest dbBuildTools4 "bt4" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)]) - , runTest $ mkTest dbBuildTools5 "bt5" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)]) - , runTest $ mkTest dbBuildTools6 "bt6" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)]) + -- build-tool-depends dependencies + , testGroup "build-tool-depends" [ + runTest $ mkTest dbBuildTools "simple exe dependency" ["A"] (solverSuccess [("A", 1), ("bt-pkg", 2)]) + + , runTest $ disableSolveExecutables $ + mkTest dbBuildTools "don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) + + , runTest $ mkTest dbBuildTools "flagged exe dependency" ["B"] (solverSuccess [("B", 1), ("bt-pkg", 2)]) + + , runTest $ enableAllTests $ + mkTest dbBuildTools "test suite exe dependency" ["C"] (solverSuccess [("C", 1), ("bt-pkg", 2)]) + + , runTest $ mkTest dbBuildTools "unknown exe" ["D"] $ + solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by D") + + , runTest $ disableSolveExecutables $ + mkTest dbBuildTools "don't check for build tool executables in legacy mode" ["D"] $ solverSuccess [("D", 1)] + + , runTest $ mkTest dbBuildTools "unknown build tools package error mentions package, not exe" ["E"] $ + solverFailure (isInfixOf "unknown package: E:unknown-pkg:exe.unknown-pkg (dependency of E)") + + , runTest $ mkTest dbBuildTools "unknown flagged exe" ["F"] $ + solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by F +flagF") + + , runTest $ enableAllTests $ mkTest dbBuildTools "unknown test suite exe" ["G"] $ + solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by G *test") + + , runTest $ mkTest dbBuildTools "wrong exe for build tool package version" ["H"] $ + solverFailure $ isInfixOf $ + -- The solver reports the version conflict when a version conflict + -- and an executable conflict apply to the same package version. + "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n" + ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable exe1, which is required by H)\n" + ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0, H:bt-pkg:exe.bt-pkg-1.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)" + + , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success" + + , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure" + + , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency" + + , runTest $ requireConsistentBuildToolVersions "build tool versions must be consistent within one package" + ] + -- build-tools dependencies + , testGroup "legacy build-tools" [ + runTest $ mkTest dbLegacyBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)]) + + , runTest $ disableSolveExecutables $ + mkTest dbLegacyBuildTools1 "bt1 - don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) + + , runTest $ mkTest dbLegacyBuildTools2 "bt2" ["A"] $ + solverFailure (isInfixOf "does not contain executable alex, which is required by A") + + , runTest $ disableSolveExecutables $ + mkTest dbLegacyBuildTools2 "bt2 - don't check for build tool executables in legacy mode" ["A"] (solverSuccess [("A", 1)]) + + , runTest $ mkTest dbLegacyBuildTools3 "bt3" ["A"] (solverSuccess [("A", 1)]) + + , runTest $ mkTest dbLegacyBuildTools4 "bt4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)]) + + , runTest $ mkTest dbLegacyBuildTools5 "bt5" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)]) + + , runTest $ mkTest dbLegacyBuildTools6 "bt6" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)]) ] + -- internal dependencies + , testGroup "internal dependencies" [ + runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)]) + ] -- Tests for the contents of the solver's log , testGroup "Solver log" [ -- See issue #3203. The solver should only choose a version for A once. @@ -278,6 +346,25 @@ ++ "these were the goals I've had most trouble fulfilling: A, B" in mkTest db "exhaustive search failure message" ["A"] $ solverFailure (isInfixOf msg) + , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $ + "Could not resolve dependencies:\n" + ++ "[__0] trying: A-1.0.0 (user goal)\n" + ++ "[__1] unknown package: D (dependency of A)\n" + ++ "[__1] fail (backjumping, conflict set: A, D)\n" + ++ "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: A, D" + , testSummarizedLog "show first conflicts after inexhaustive search" (Just 2) $ + "Could not resolve dependencies:\n" + ++ "[__0] trying: A-1.0.0 (user goal)\n" + ++ "[__1] trying: B-3.0.0 (dependency of A)\n" + ++ "[__2] next goal: C (dependency of B)\n" + ++ "[__2] rejecting: C-1.0.0 (conflict: B => C==3.0.0)\n" + ++ "Backjump limit reached (currently 2, change with --max-backjumps " + ++ "or try to run with --reorder-goals).\n" + , testSummarizedLog "don't show summarized log when backjump limit is too low" (Just 1) $ + "Backjump limit reached (currently 1, change with --max-backjumps " + ++ "or try to run with --reorder-goals).\n" + ++ "Failed to generate a summarized dependency solver log due to low backjump limit." ] ] where @@ -456,6 +543,35 @@ , Right $ exAv "D" 1 [ExAny "B"] ] +-- | This test checks that the solver can backjump to disable a flag, even if +-- the problematic dependency is also under a test suite. (issue #4390) +-- +-- The goal order forces the solver to choose the flag before enabling testing. +-- Previously, the solver couldn't handle this case, because it only tried to +-- disable testing, and when that failed, it backjumped past the flag choice. +-- The solver should also try to set the flag to false, because that avoids the +-- dependency on B. +testTestSuiteWithFlag :: String -> SolverTest +testTestSuiteWithFlag name = + goalOrder goals $ enableAllTests $ mkTest db name ["A", "B"] $ + solverSuccess [("A", 1), ("B", 1)] + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [] + `withTest` + ExTest "test" [exFlagged "flag" [ExFix "B" 2] []] + , Right $ exAv "B" 1 [] + ] + + goals :: [ExampleVar] + goals = [ + P QualNone "B" + , P QualNone "A" + , F QualNone "A" "flag" + , S QualNone "A" TestStanzas + ] + -- Packages with setup dependencies -- -- Install.. @@ -624,6 +740,32 @@ Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "unknown"] ] +-- | This is a test case for a bug in stanza preferences (#3930). The solver +-- should be able to install 'A' by enabling 'flag' and disabling testing. When +-- it tries goals in the specified order and prefers testing, it encounters +-- 'unknown-pkg2'. 'unknown-pkg2' is only introduced by testing and 'flag', so +-- the conflict set should contain both of those variables. Before the fix, it +-- only contained 'flag'. The solver backjumped past the choice to disable +-- testing and failed to find the solution. +testStanzaPreference :: String -> TestTree +testStanzaPreference name = + let pkg = exAv "A" 1 [exFlagged "flag" + [] + [ExAny "unknown-pkg1"]] + `withTest` + ExTest "test" [exFlagged "flag" + [ExAny "unknown-pkg2"] + []] + goals = [ + P QualNone "A" + , F QualNone "A" "flag" + , S QualNone "A" TestStanzas + ] + in runTest $ goalOrder goals $ + preferences [ ExStanzaPref "A" [TestStanzas]] $ + mkTest [Right pkg] name ["A"] $ + solverSuccess [("A", 1)] + -- | Database with some cycles -- -- * Simplest non-trivial cycle: A -> B and B -> A @@ -661,6 +803,30 @@ , Right $ exAv "E" 1 [ExFix "C" 2] ] +-- | Detect a cycle between a package and its setup script. +-- +-- This type of cycle can easily occur when new-build adds default setup +-- dependencies to packages without custom-setup stanzas. For example, cabal +-- adds 'time' as a setup dependency for 'time'. The solver should detect the +-- cycle when it attempts to link the setup and non-setup instances of the +-- package and then choose a different version for the setup dependency. +issue4161 :: String -> SolverTest +issue4161 name = + mkTest db name ["target"] $ + SolverResult checkFullLog $ Right [("target", 1), ("time", 1), ("time", 2)] + where + db :: ExampleDb + db = [ + Right $ exAv "target" 1 [ExFix "time" 2] + , Right $ exAv "time" 2 [] `withSetupDeps` [ExAny "time"] + , Right $ exAv "time" 1 [] + ] + + checkFullLog :: [String] -> Bool + checkFullLog = any $ isInfixOf $ + "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; " + ++ "conflict set: time:setup.time)" + -- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack -- as soon as it chooses the last package in the cycle, to avoid searching parts -- of the tree that have no solution. Since there is no way to break the cycle, @@ -692,7 +858,7 @@ -- Solve for pkg-D and pkg-E last. goals :: [ExampleVar] - goals = [P None ("pkg-" ++ [c]) | c <- ['A'..'E']] + goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A'..'E']] -- | Check that the solver can backtrack after encountering the SIR (issue #2843) -- @@ -752,14 +918,14 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "A" - , P (Indep 0) "C" - , P (Indep 0) "D" - , P (Indep 1) "B" - , P (Indep 1) "C" - , P (Indep 1) "D" - , S (Indep 1) "B" TestStanzas - , S (Indep 0) "A" TestStanzas + P (QualIndep "A") "A" + , P (QualIndep "A") "C" + , P (QualIndep "A") "D" + , P (QualIndep "B") "B" + , P (QualIndep "B") "C" + , P (QualIndep "B") "D" + , S (QualIndep "B") "B" TestStanzas + , S (QualIndep "A") "A" TestStanzas ] -- | Issue #2834 @@ -794,6 +960,61 @@ , Right $ exAv "G" 1 [] ] +-- | When both values for flagA introduce package B, the solver should be able +-- to choose B before choosing a value for flagA. It should try to choose a +-- version for B that is in the union of the version ranges required by +flagA +-- and -flagA. +commonDependencyLogMessage :: String -> SolverTest +commonDependencyLogMessage name = + mkTest db name ["A"] $ solverFailure $ isInfixOf $ + "[__0] trying: A-1.0.0 (user goal)\n" + ++ "[__1] next goal: B (dependency of A +/-flagA)\n" + ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)" + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [exFlagged "flagA" + [ExFix "B" 1] + [ExFix "B" 3]] + , Right $ exAv "B" 2 [] + ] + +-- | Test lifting dependencies out of multiple levels of conditionals. +twoLevelDeepCommonDependencyLogMessage :: String -> SolverTest +twoLevelDeepCommonDependencyLogMessage name = + mkTest db name ["A"] $ solverFailure $ isInfixOf $ + "unknown package: B (dependency of A +/-flagA +/-flagB)" + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [exFlagged "flagA" + [exFlagged "flagB" + [ExAny "B"] + [ExAny "B"]] + [exFlagged "flagB" + [ExAny "B"] + [ExAny "B"]]] + ] + +-- | Test handling nested conditionals that are controlled by the same flag. +-- The solver should treat flagA as introducing 'unknown' with value true, not +-- both true and false. That means that when +flagA causes a conflict, the +-- solver should try flipping flagA to false to resolve the conflict, rather +-- than backjumping past flagA. +testBackjumpingWithCommonDependency :: String -> SolverTest +testBackjumpingWithCommonDependency name = + mkTest db name ["A"] $ solverSuccess [("A", 1), ("B", 1)] + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [exFlagged "flagA" + [exFlagged "flagA" + [ExAny "unknown"] + [ExAny "unknown"]] + [ExAny "B"]] + , Right $ exAv "B" 1 [] + ] + -- | Tricky test case with independent goals (issue #2842) -- -- Suppose we are installing D, E, and F as independent goals: @@ -836,16 +1057,16 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "D" - , P (Indep 0) "C" - , P (Indep 0) "A" - , P (Indep 1) "E" - , P (Indep 1) "C" - , P (Indep 1) "B" - , P (Indep 2) "F" - , P (Indep 2) "B" - , P (Indep 2) "C" - , P (Indep 2) "A" + P (QualIndep "D") "D" + , P (QualIndep "D") "C" + , P (QualIndep "D") "A" + , P (QualIndep "E") "E" + , P (QualIndep "E") "C" + , P (QualIndep "E") "B" + , P (QualIndep "F") "F" + , P (QualIndep "F") "B" + , P (QualIndep "F") "C" + , P (QualIndep "F") "A" ] -- | This test checks that the solver correctly backjumps when dependencies @@ -878,15 +1099,15 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "A" - , P (Indep 0) "E" - , P (Indep 1) "B" - , P (Indep 1) "D" - , P (Indep 1) "E" - , P (Indep 2) "C" - , P (Indep 2) "D" - , P (Indep 2) "E" - , S (Indep 2) "C" TestStanzas + P (QualIndep "A") "A" + , P (QualIndep "A") "E" + , P (QualIndep "B") "B" + , P (QualIndep "B") "D" + , P (QualIndep "B") "E" + , P (QualIndep "C") "C" + , P (QualIndep "C") "D" + , P (QualIndep "C") "E" + , S (QualIndep "C") "C" TestStanzas ] -- | Test the trace messages that we get when a package refers to an unknown pkg @@ -955,14 +1176,14 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "X" - , P (Indep 0) "A" - , P (Indep 0) "B" - , P (Indep 0) "C" - , P (Indep 1) "Y" - , P (Indep 1) "A" - , P (Indep 1) "B" - , P (Indep 1) "C" + P (QualIndep "X") "X" + , P (QualIndep "X") "A" + , P (QualIndep "X") "B" + , P (QualIndep "X") "C" + , P (QualIndep "Y") "Y" + , P (QualIndep "Y") "A" + , P (QualIndep "Y") "B" + , P (QualIndep "Y") "C" ] -- | A simplified version of 'testIndepGoals5'. @@ -989,12 +1210,12 @@ goals :: [ExampleVar] goals = [ - P (Indep 0) "X" - , P (Indep 0) "A" - , P (Indep 0) "B" - , P (Indep 1) "Y" - , P (Indep 1) "A" - , P (Indep 1) "B" + P (QualIndep "X") "X" + , P (QualIndep "X") "A" + , P (QualIndep "X") "B" + , P (QualIndep "Y") "Y" + , P (QualIndep "Y") "A" + , P (QualIndep "Y") "B" ] dbExts1 :: ExampleDb @@ -1080,6 +1301,29 @@ , Right $ exAv "C" 1 [ExAny "B"] ] +-- | Test for the solver's summarized log. The final conflict set is {A, D}, +-- though the goal order forces the solver to find the (avoidable) conflict +-- between B >= 2 and C first. When the solver reaches the backjump limit, it +-- should only show the log to the first conflict. When the backjump limit is +-- high enough to allow an exhaustive search, the solver should make use of the +-- final conflict set to only show the conflict between A and D in the +-- summarized log. +testSummarizedLog :: String -> Maybe Int -> String -> TestTree +testSummarizedLog testName mbj expectedMsg = + runTest $ maxBackjumps mbj $ goalOrder goals $ mkTest db testName ["A"] $ + solverFailure (== expectedMsg) + where + db = [ + Right $ exAv "A" 1 [ExAny "B", ExAny "D"] + , Right $ exAv "B" 3 [ExFix "C" 3] + , Right $ exAv "B" 2 [ExFix "C" 2] + , Right $ exAv "B" 1 [ExAny "C"] + , Right $ exAv "C" 1 [] + ] + + goals :: [ExampleVar] + goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]] + {------------------------------------------------------------------------------- Simple databases for the illustrations for the backjumping blog post -------------------------------------------------------------------------------} @@ -1177,52 +1421,155 @@ ] {------------------------------------------------------------------------------- - Databases for build-tools + Databases for build-tool-depends -------------------------------------------------------------------------------} -dbBuildTools1 :: ExampleDb -dbBuildTools1 = [ - Right $ exAv "alex" 1 [], - Right $ exAv "A" 1 [ExBuildToolAny "alex"] + +-- | Multiple packages depending on exes from 'bt-pkg'. +dbBuildTools :: ExampleDb +dbBuildTools = [ + Right $ exAv "A" 1 [ExBuildToolAny "bt-pkg" "exe1"] + , Right $ exAv "B" 1 [exFlagged "flagB" [ExAny "unknown"] + [ExBuildToolAny "bt-pkg" "exe1"]] + , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExBuildToolAny "bt-pkg" "exe1"] + , Right $ exAv "D" 1 [ExBuildToolAny "bt-pkg" "unknown-exe"] + , Right $ exAv "E" 1 [ExBuildToolAny "unknown-pkg" "exe1"] + , Right $ exAv "F" 1 [exFlagged "flagF" [ExBuildToolAny "bt-pkg" "unknown-exe"] + [ExAny "unknown"]] + , Right $ exAv "G" 1 [] `withTest` ExTest "testG" [ExBuildToolAny "bt-pkg" "unknown-exe"] + , Right $ exAv "H" 1 [ExBuildToolFix "bt-pkg" "exe1" 3] + + , Right $ exAv "bt-pkg" 4 [] + , Right $ exAv "bt-pkg" 3 [] `withExe` ExExe "exe2" [] + , Right $ exAv "bt-pkg" 2 [] `withExe` ExExe "exe1" [] + , Right $ exAv "bt-pkg" 1 [] ] +-- The solver should never choose an installed package for a build tool +-- dependency. +rejectInstalledBuildToolPackage :: String -> SolverTest +rejectInstalledBuildToolPackage name = + mkTest db name ["A"] $ solverFailure $ isInfixOf $ + "rejecting: A:B:exe.B-1.0.0/installed-1 " + ++ "(does not contain executable exe, which is required by A)" + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ExBuildToolAny "B" "exe"] + , Left $ exInst "B" 1 "B-1" [] + ] + +-- | This test forces the solver to choose B as a build-tool dependency before +-- it sees the dependency on executable exe2 from B. The solver needs to check +-- that the version that it already chose for B contains the necessary +-- executable. This order causes a different "missing executable" error message +-- than when the solver checks for the executable in the same step that it +-- chooses the build-tool package. +-- +-- This case may become impossible if we ever add the executable name to the +-- build-tool goal qualifier. Then this test would involve two qualified goals +-- for B, one for exe1 and another for exe2. +chooseExeAfterBuildToolsPackage :: Bool -> String -> SolverTest +chooseExeAfterBuildToolsPackage shouldSucceed name = + goalOrder goals $ mkTest db name ["A"] $ + if shouldSucceed + then solverSuccess [("A", 1), ("B", 1)] + else solverFailure $ isInfixOf $ + "rejecting: A:+flagA (requires executable exe2 from A:B:exe.B, " + ++ "but the executable does not exist)" + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ ExBuildToolAny "B" "exe1" + , exFlagged "flagA" [ExBuildToolAny "B" "exe2"] + [ExAny "unknown"]] + , Right $ exAv "B" 1 [] + `withExes` + [ExExe exe [] | exe <- if shouldSucceed then ["exe1", "exe2"] else ["exe1"]] + ] + + goals :: [ExampleVar] + goals = [ + P QualNone "A" + , P (QualExe "A" "B") "B" + , F QualNone "A" "flagA" + ] + +-- | Test that when one package depends on two executables from another package, +-- both executables must come from the same instance of that package. We could +-- lift this restriction in the future by adding the executable name to the goal +-- qualifier. +requireConsistentBuildToolVersions :: String -> SolverTest +requireConsistentBuildToolVersions name = + mkTest db name ["A"] $ solverFailure $ isInfixOf $ + "[__1] rejecting: A:B:exe.B-2.0.0 (conflict: A => A:B:exe.B (exe exe1)==1.0.0)\n" + ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)" + where + db :: ExampleDb + db = [ + Right $ exAv "A" 1 [ ExBuildToolFix "B" "exe1" 1 + , ExBuildToolFix "B" "exe2" 2 ] + , Right $ exAv "B" 2 [] `withExes` exes + , Right $ exAv "B" 1 [] `withExes` exes + ] + + exes = [ExExe "exe1" [], ExExe "exe2" []] + +{------------------------------------------------------------------------------- + Databases for legacy build-tools +-------------------------------------------------------------------------------} +dbLegacyBuildTools1 :: ExampleDb +dbLegacyBuildTools1 = [ + Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [], + Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] + ] + +-- Test that a recognized build tool dependency specifies the name of both the +-- package and the executable. This db has no solution. +dbLegacyBuildTools2 :: ExampleDb +dbLegacyBuildTools2 = [ + Right $ exAv "alex" 1 [] `withExe` ExExe "other-exe" [], + Right $ exAv "other-package" 1 [] `withExe` ExExe "alex" [], + Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] + ] + -- Test that build-tools on a random thing doesn't matter (only -- the ones we recognize need to be in db) -dbBuildTools2 :: ExampleDb -dbBuildTools2 = [ - Right $ exAv "A" 1 [ExBuildToolAny "otherdude"] +dbLegacyBuildTools3 :: ExampleDb +dbLegacyBuildTools3 = [ + Right $ exAv "A" 1 [ExLegacyBuildToolAny "otherdude"] ] -- Test that we can solve for different versions of executables -dbBuildTools3 :: ExampleDb -dbBuildTools3 = [ - Right $ exAv "alex" 1 [], - Right $ exAv "alex" 2 [], - Right $ exAv "A" 1 [ExBuildToolFix "alex" 1], - Right $ exAv "B" 1 [ExBuildToolFix "alex" 2], +dbLegacyBuildTools4 :: ExampleDb +dbLegacyBuildTools4 = [ + Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [], + Right $ exAv "alex" 2 [] `withExe` ExExe "alex" [], + Right $ exAv "A" 1 [ExLegacyBuildToolFix "alex" 1], + Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 2], Right $ exAv "C" 1 [ExAny "A", ExAny "B"] ] -- Test that exe is not related to library choices -dbBuildTools4 :: ExampleDb -dbBuildTools4 = [ - Right $ exAv "alex" 1 [ExFix "A" 1], +dbLegacyBuildTools5 :: ExampleDb +dbLegacyBuildTools5 = [ + Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` ExExe "alex" [], Right $ exAv "A" 1 [], Right $ exAv "A" 2 [], - Right $ exAv "B" 1 [ExBuildToolFix "alex" 1, ExFix "A" 2] + Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 1, ExFix "A" 2] ] -- Test that build-tools on build-tools works -dbBuildTools5 :: ExampleDb -dbBuildTools5 = [ - Right $ exAv "alex" 1 [], - Right $ exAv "happy" 1 [ExBuildToolAny "alex"], - Right $ exAv "A" 1 [ExBuildToolAny "happy"] +dbLegacyBuildTools6 :: ExampleDb +dbLegacyBuildTools6 = [ + Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [], + Right $ exAv "happy" 1 [ExLegacyBuildToolAny "alex"] `withExe` ExExe "happy" [], + Right $ exAv "A" 1 [ExLegacyBuildToolAny "happy"] ] -- Test that build-depends on library/executable package works. -- Extracted from https://github.com/haskell/cabal/issues/3775 -dbBuildTools6 :: ExampleDb -dbBuildTools6 = [ +dbIssue3775 :: ExampleDb +dbIssue3775 = [ Right $ exAv "warp" 1 [], -- NB: the warp build-depends refers to the package, not the internal -- executable!