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 @@ -1,3 +1,5 @@ +-- TODO +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Reporting diff --git a/Distribution/Client/BuildReports/Types.hs b/Distribution/Client/BuildReports/Types.hs --- a/Distribution/Client/BuildReports/Types.hs +++ b/Distribution/Client/BuildReports/Types.hs @@ -27,12 +27,14 @@ ( isAlpha, toLower ) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary) +import Distribution.Utils.Structured (Structured) data ReportLevel = NoReports | AnonymousReports | DetailedReports deriving (Eq, Ord, Enum, Show, Generic) instance Binary ReportLevel +instance Structured ReportLevel instance Text.Text ReportLevel where disp NoReports = Disp.text "none" diff --git a/Distribution/Client/CmdBench.hs b/Distribution/Client/CmdBench.hs --- a/Distribution/Client/CmdBench.hs +++ b/Distribution/Client/CmdBench.hs @@ -20,7 +20,7 @@ ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Deprecated.Text @@ -33,7 +33,9 @@ import Control.Monad (when) -benchCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +benchCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) benchCommand = Client.installCommand { commandName = "v2-bench", commandSynopsis = "Run benchmarks", @@ -73,9 +75,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +benchAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -benchAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +benchAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand @@ -119,7 +123,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/Distribution/Client/CmdBuild.hs b/Distribution/Client/CmdBuild.hs --- a/Distribution/Client/CmdBuild.hs +++ b/Distribution/Client/CmdBuild.hs @@ -11,16 +11,18 @@ selectComponentTarget ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages -import Distribution.Compat.Semigroup ((<>)) import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags , liftOptions, yesNoOpt ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, TestFlags + ( HaddockFlags, TestFlags, BenchmarkFlags , Flag(..), toFlag, fromFlag, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives, option ) @@ -35,7 +37,8 @@ buildCommand :: CommandUI (BuildFlags, ( ConfigFlags, ConfigExFlags - , InstallFlags, HaddockFlags, TestFlags)) + , InstallFlags, HaddockFlags + , TestFlags, BenchmarkFlags )) buildCommand = CommandUI { commandName = "v2-build", commandSynopsis = "Compile targets within the project.", @@ -103,11 +106,13 @@ -- buildAction :: ( BuildFlags - , (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)) + , ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags )) -> [String] -> GlobalFlags -> IO () buildAction ( buildFlags - , (configFlags, configExFlags, installFlags, haddockFlags, testFlags)) + , ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags )) targetStrings globalFlags = do -- TODO: This flags defaults business is ugly let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags @@ -159,7 +164,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/Distribution/Client/CmdConfigure.hs b/Distribution/Client/CmdConfigure.hs --- a/Distribution/Client/CmdConfigure.hs +++ b/Distribution/Client/CmdConfigure.hs @@ -16,7 +16,7 @@ import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Verbosity ( normal ) @@ -26,8 +26,9 @@ ( wrapText, notice ) import qualified Distribution.Client.Setup as Client -configureCommand :: CommandUI (ConfigFlags, ConfigExFlags - ,InstallFlags, HaddockFlags, TestFlags) +configureCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) configureCommand = Client.installCommand { commandName = "v2-configure", commandSynopsis = "Add extra project configuration", @@ -78,9 +79,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +configureAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -configureAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +configureAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) _extraArgs globalFlags = do --TODO: deal with _extraArgs, since flags with wrong syntax end up there @@ -123,5 +126,5 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags diff --git a/Distribution/Client/CmdErrorMessages.hs b/Distribution/Client/CmdErrorMessages.hs --- a/Distribution/Client/CmdErrorMessages.hs +++ b/Distribution/Client/CmdErrorMessages.hs @@ -7,6 +7,9 @@ module Distribution.Client.TargetSelector, ) where +import Distribution.Client.Compat.Prelude +import Prelude () + import Distribution.Client.ProjectOrchestration import Distribution.Client.TargetSelector ( ComponentKindFilter, componentKind, showTargetSelector ) @@ -22,8 +25,7 @@ import Distribution.Deprecated.Text ( display ) -import Data.Maybe (isNothing) -import Data.List (sortBy, groupBy, nub) +import qualified Data.List.NonEmpty as NE import Data.Function (on) @@ -77,8 +79,8 @@ -- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] -- sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])] -sortGroupOn key = map (\xs@(x:_) -> (key x, xs)) - . groupBy ((==) `on` key) +sortGroupOn key = map (\(x:|xs) -> (key x, x:xs)) + . NE.groupBy ((==) `on` key) . sortBy (compare `on` key) diff --git a/Distribution/Client/CmdExec.hs b/Distribution/Client/CmdExec.hs --- a/Distribution/Client/CmdExec.hs +++ b/Distribution/Client/CmdExec.hs @@ -76,11 +76,13 @@ import Distribution.Simple.Setup ( HaddockFlags , TestFlags + , BenchmarkFlags , fromFlagOrDefault ) import Distribution.Simple.Utils ( die' , info + , createDirectoryIfMissingVerbose , withTempDirectory , wrapText ) @@ -92,11 +94,12 @@ 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, TestFlags) +execCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) execCommand = CommandUI { commandName = "v2-exec" , commandSynopsis = "Give a command access to the store." @@ -121,9 +124,11 @@ , commandDefaultFlags = commandDefaultFlags Client.installCommand } -execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +execAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -execAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +execAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand @@ -197,7 +202,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags withOverrides env args program = program { programOverrideEnv = programOverrideEnv program ++ env , programDefaultArgs = programDefaultArgs program ++ args} @@ -219,11 +224,8 @@ -> PostBuildProjectStatus -> ([(String, Maybe String)] -> IO a) -> IO a -withTempEnvFile verbosity - baseCtx - buildCtx - buildStatus - action = +withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do + createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx)) withTempDirectory verbosity (distTempDirectory (distDirLayout baseCtx)) diff --git a/Distribution/Client/CmdFreeze.hs b/Distribution/Client/CmdFreeze.hs --- a/Distribution/Client/CmdFreeze.hs +++ b/Distribution/Client/CmdFreeze.hs @@ -33,7 +33,7 @@ import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText ) import Distribution.Verbosity @@ -49,7 +49,9 @@ import qualified Distribution.Client.Setup as Client -freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +freezeCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) freezeCommand = Client.installCommand { commandName = "v2-freeze", commandSynopsis = "Freeze dependencies.", @@ -99,9 +101,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +freezeAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -freezeAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +freezeAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do unless (null extraArgs) $ @@ -132,7 +136,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags diff --git a/Distribution/Client/CmdHaddock.hs b/Distribution/Client/CmdHaddock.hs --- a/Distribution/Client/CmdHaddock.hs +++ b/Distribution/Client/CmdHaddock.hs @@ -20,7 +20,7 @@ ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags(..), TestFlags, fromFlagOrDefault ) + ( HaddockFlags(..), TestFlags, BenchmarkFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity @@ -31,8 +31,9 @@ import Control.Monad (when) -haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags - ,HaddockFlags, TestFlags) +haddockCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) haddockCommand = Client.installCommand { commandName = "v2-haddock", commandSynopsis = "Build Haddock documentation", @@ -69,9 +70,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +haddockAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -haddockAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +haddockAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand @@ -113,7 +116,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @haddock@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/Distribution/Client/CmdInstall.hs b/Distribution/Client/CmdInstall.hs --- a/Distribution/Client/CmdInstall.hs +++ b/Distribution/Client/CmdInstall.hs @@ -32,7 +32,7 @@ import Distribution.Client.Setup ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) , configureExOptions, haddockOptions, installOptions, testOptions - , configureOptions, liftOptions ) + , benchmarkOptions, configureOptions, liftOptions ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) ) import Distribution.Client.Types @@ -73,7 +73,7 @@ ( getSourcePackages, getInstalledPackages ) import Distribution.Client.ProjectConfig ( readGlobalConfig, projectConfigWithBuilderRepoContext - , resolveBuildTimeSettings, withProjectOrGlobalConfig ) + , resolveBuildTimeSettings, withProjectOrGlobalConfigIgn ) import Distribution.Client.ProjectPlanning ( storePackageInstallDirs' ) import qualified Distribution.Simple.InstallDirs as InstallDirs @@ -87,7 +87,8 @@ import Distribution.Client.InstallSymlink ( OverwritePolicy(..), symlinkBinary ) import Distribution.Simple.Setup - ( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe ) + ( Flag(..), HaddockFlags, TestFlags, BenchmarkFlags + , fromFlagOrDefault, flagToMaybe ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.Simple.Command @@ -107,7 +108,7 @@ import Distribution.Types.UnitId ( UnitId ) import Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName, mkUnqualComponentName ) + ( UnqualComponentName, unUnqualComponentName ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils @@ -115,7 +116,7 @@ , withTempDirectory, createDirectoryIfMissingVerbose , ordNub ) import Distribution.Utils.Generic - ( writeFileAtomic ) + ( safeHead, writeFileAtomic ) import Distribution.Deprecated.Text ( simpleParse ) import Distribution.Pretty @@ -124,7 +125,7 @@ import Control.Exception ( catch ) import Control.Monad - ( mapM, mapM_ ) + ( mapM, forM_ ) import qualified Data.ByteString.Lazy.Char8 as BS import Data.Either ( partitionEithers ) @@ -142,7 +143,8 @@ installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags - , HaddockFlags, TestFlags, ClientInstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + , ClientInstallFlags ) installCommand = CommandUI { commandName = "v2-install" @@ -178,7 +180,8 @@ (filter ((`notElem` ["constraint", "dependency" , "exact-configuration"]) . optionName) $ configureOptions showOrParseArgs) - ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs + ConstraintSourceCommandlineFlag) ++ liftOptions get3 set3 -- hide "target-package-db" and "symlink-bindir" flags from the -- install options. @@ -193,16 +196,19 @@ . optionName) $ haddockOptions showOrParseArgs) ++ liftOptions get5 set5 (testOptions showOrParseArgs) - ++ liftOptions get6 set6 (clientInstallOptions showOrParseArgs) - , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, defaultClientInstallFlags) + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) + ++ liftOptions get7 set7 (clientInstallOptions showOrParseArgs) + , commandDefaultFlags = ( mempty, mempty, mempty, mempty, mempty, mempty + , defaultClientInstallFlags ) } where - get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) - get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) - get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) - get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) - get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) - get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) + get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g) + get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g) + get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g) + get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g) + get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g) + get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g) + get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) -- | The @install@ command actually serves four different needs. It installs: @@ -222,10 +228,16 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ClientInstallFlags) - -> [String] -> GlobalFlags -> IO () -installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, clientInstallFlags') - targetStrings globalFlags = do +installAction + :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + , ClientInstallFlags) + -> [String] -> GlobalFlags + -> IO () +installAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags + , clientInstallFlags' ) + 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. @@ -245,38 +257,49 @@ pure $ savedClientInstallFlags savedConfig `mappend` clientInstallFlags' let - installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) - targetFilter = if installLibs then Just LibKind else Just ExeKind + installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) + targetFilter = if installLibs then Just LibKind else Just ExeKind targetStrings' = if null targetStrings then ["."] else targetStrings + withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector], ProjectConfig) withProject = do let verbosity' = lessVerbose verbosity -- First, we need to learn about what's available to be installed. - localBaseCtx <- establishProjectBaseContext verbosity' cliConfig InstallCommand + localBaseCtx <- establishProjectBaseContext verbosity' + cliConfig InstallCommand let localDistDirLayout = distDirLayout localBaseCtx - pkgDb <- projectConfigWithBuilderRepoContext verbosity' (buildSettings localBaseCtx) (getSourcePackages verbosity) + pkgDb <- projectConfigWithBuilderRepoContext verbosity' + (buildSettings localBaseCtx) (getSourcePackages verbosity) let - (targetStrings'', packageIds) = partitionEithers . flip fmap targetStrings' $ + (targetStrings'', packageIds) = + partitionEithers . + flip fmap targetStrings' $ \str -> case simpleParse str of Just (pkgId :: PackageId) | pkgVersion pkgId /= nullVersion -> Right pkgId - _ -> Left str - packageSpecifiers = flip fmap packageIds $ \case + _ -> Left str + packageSpecifiers = + flip fmap packageIds $ \case PackageIdentifier{..} | pkgVersion == nullVersion -> NamedPackage pkgName [] - | otherwise -> - NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] - packageTargets = flip TargetPackageNamed targetFilter . pkgName <$> packageIds + | otherwise -> NamedPackage pkgName + [PackagePropertyVersion + (thisVersion pkgVersion)] + packageTargets = + flip TargetPackageNamed targetFilter . pkgName <$> packageIds if null targetStrings' then return (packageSpecifiers, packageTargets, projectConfig localBaseCtx) else do - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages localBaseCtx) Nothing targetStrings'' + targetSelectors <- + either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages localBaseCtx) + Nothing targetStrings'' - (specs, selectors) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan _ -> do + (specs, selectors) <- + withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan _ -> do -- Split into known targets and hackage packages. (targets, hackageNames) <- case resolveTargets @@ -286,10 +309,10 @@ elaboratedPlan (Just pkgDb) targetSelectors of - Right targets -> do + Right targets -> -- Everything is a local dependency. return (targets, []) - Left errs -> do + Left errs -> do -- Not everything is local. let (errs', hackageNames) = partitionEithers . flip fmap errs $ \case @@ -316,10 +339,13 @@ | name `elem` hackageNames -> False TargetPackageNamed name _ | name `elem` hackageNames -> False - _ -> True + _ -> True - -- This can't fail, because all of the errors are removed (or we've given up). - targets <- either (reportTargetProblems verbosity) return $ resolveTargets + -- This can't fail, because all of the errors are + -- removed (or we've given up). + targets <- + either (reportTargetProblems verbosity) return $ + resolveTargets selectPackageTargets selectComponentTarget TargetProblemCommon @@ -333,7 +359,8 @@ planMap = InstallPlan.toMap elaboratedPlan targetIds = Map.keys targets - sdistize (SpecificSourcePackage spkg@SourcePackage{..}) = SpecificSourcePackage spkg' + sdistize (SpecificSourcePackage spkg@SourcePackage{..}) = + SpecificSourcePackage spkg' where sdistPath = distSdistFile localDistDirLayout packageInfoId spkg' = spkg { packageSource = LocalTarballPackage sdistPath } @@ -344,31 +371,35 @@ gatherTargets :: UnitId -> TargetSelector gatherTargets targetId = TargetPackageNamed pkgName targetFilter where - Just targetUnit = Map.lookup targetId planMap + targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap PackageIdentifier{..} = packageId targetUnit targets' = fmap gatherTargets targetIds hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] hackagePkgs = flip NamedPackage [] <$> hackageNames + hackageTargets :: [TargetSelector] - hackageTargets = flip TargetPackageNamed targetFilter <$> hackageNames + hackageTargets = + flip TargetPackageNamed targetFilter <$> hackageNames createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) - unless (Map.null targets) $ - mapM_ - (\(SpecificSourcePackage pkg) -> packageToSdist verbosity + unless (Map.null targets) $ forM_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of + SpecificSourcePackage pkg -> packageToSdist verbosity (distProjectRootDirectory localDistDirLayout) TarGzArchive (distSdistFile localDistDirLayout (packageId pkg)) pkg - ) (localPackages localBaseCtx) + NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName if null targets then return (hackagePkgs, hackageTargets) else return (local ++ hackagePkgs, targets' ++ hackageTargets) - return (specs ++ packageSpecifiers, selectors ++ packageTargets, projectConfig localBaseCtx) + return ( specs ++ packageSpecifiers + , selectors ++ packageTargets + , projectConfig localBaseCtx ) + withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [TargetSelector], ProjectConfig) withoutProject globalConfig = do let parsePkg pkgName @@ -415,21 +446,29 @@ packageSpecifiers = flip fmap packageIds $ \case PackageIdentifier{..} | pkgVersion == nullVersion -> NamedPackage pkgName [] - | otherwise -> - NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] + | otherwise -> NamedPackage pkgName + [PackagePropertyVersion + (thisVersion pkgVersion)] packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds return (packageSpecifiers, packageTargets, projectConfig) - (specs, selectors, config) <- withProjectOrGlobalConfig verbosity globalConfigFlag - withProject withoutProject + let + ignoreProject = fromFlagOrDefault False (cinstIgnoreProject clientInstallFlags) + (specs, selectors, config) <- + withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag withProject withoutProject + home <- getHomeDirectory let ProjectConfig { + projectConfigBuildOnly = ProjectConfigBuildOnly { + projectConfigLogsDir + }, projectConfigShared = ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, - projectConfigHcPkg + projectConfigHcPkg, + projectConfigStoreDir }, projectConfigLocalPackages = PackageConfig { packageConfigProgramPaths, @@ -461,20 +500,21 @@ home ".ghc" ghcPlatformAndVersionString platform compilerVersion "environments" name localEnv dir = - dir ".ghc.environment." ++ ghcPlatformAndVersionString platform compilerVersion + dir + ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler -- Why? We know what the first part will be, we only care about the packages. filterEnvEntries = filter $ \case GhcEnvFilePackageId _ -> True - _ -> False + _ -> False envFile <- case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of Just spec -- Is spec a bare word without any "pathy" content, then it refers to -- a named global environment. | takeBaseName spec == spec -> return (globalEnv spec) - | otherwise -> do + | otherwise -> do spec' <- makeAbsolute spec isDir <- doesDirectoryExist spec' if isDir @@ -483,7 +523,7 @@ then return (localEnv spec') -- Otherwise, treat it like a literal file path. else return spec' - Nothing -> return (globalEnv "default") + Nothing -> return (globalEnv "default") envFileExists <- doesFileExist envFile envEntries <- filterEnvEntries <$> if @@ -495,20 +535,29 @@ else return [] cabalDir <- getCabalDir - mstoreDir <- sequenceA $ makeAbsolute <$> flagToMaybe (globalStoreDir globalFlags) + mstoreDir <- + sequenceA $ makeAbsolute <$> flagToMaybe projectConfigStoreDir let - mlogsDir = flagToMaybe (globalLogsDir globalFlags) + mlogsDir = flagToMaybe projectConfigLogsDir cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir packageDbs = storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb - let (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex envEntries + let (envSpecs, envEntries') = + environmentFileToSpecifiers installedIndex envEntries -- Second, we need to use a fake project to let Cabal build the -- installables correctly. For that, we need a place to put a -- temporary dist directory. globalTmp <- getTemporaryDirectory + + -- if we are installing executables, we shouldn't take into account + -- environment specifiers. + let envSpecs' :: [PackageSpecifier a] + envSpecs' | installLibs = envSpecs + | otherwise = [] + withTempDirectory verbosity globalTmp @@ -518,7 +567,7 @@ verbosity config tmpDir - (envSpecs ++ specs) + (envSpecs' ++ specs) InstallCommand buildCtx <- @@ -560,65 +609,78 @@ -- Then, install! when (not dryRun) $ if installLibs - then installLibraries verbosity buildCtx compiler packageDbs progDb envFile envEntries' - else installExes verbosity baseCtx buildCtx platform compiler clientInstallFlags + then installLibraries verbosity + buildCtx compiler packageDbs progDb envFile envEntries' + else installExes verbosity + baseCtx buildCtx platform compiler configFlags clientInstallFlags where configFlags' = disableTestsBenchsByDefault configFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags') cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags' configExFlags installFlags clientInstallFlags' - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -- | Install any built exe by symlinking/copying it -- we don't use BuildOutcomes because we also need the component names -installExes :: Verbosity - -> ProjectBaseContext - -> ProjectBuildContext - -> Platform - -> Compiler - -> ClientInstallFlags - -> IO () +installExes + :: Verbosity + -> ProjectBaseContext + -> ProjectBuildContext + -> Platform + -> Compiler + -> ConfigFlags + -> ClientInstallFlags + -> IO () installExes verbosity baseCtx buildCtx platform compiler - clientInstallFlags = do + configFlags clientInstallFlags = do let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx - let mkUnitBinDir :: UnitId -> FilePath - mkUnitBinDir = InstallDirs.bindir . - storePackageInstallDirs' - storeDirLayout - (compilerId compiler) + + prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags)) + suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags)) + + mkUnitBinDir :: UnitId -> FilePath + mkUnitBinDir = + InstallDirs.bindir . + storePackageInstallDirs' storeDirLayout (compilerId compiler) + mkExeName :: UnqualComponentName -> FilePath mkExeName exe = unUnqualComponentName exe <.> exeExtension platform + + mkFinalExeName :: UnqualComponentName -> FilePath + mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform installdirUnknown = "installdir is not defined. Set it in your cabal config file " ++ "or use --installdir=" - installdir <- fromFlagOrDefault (die' verbosity installdirUnknown) - $ pure <$> cinstInstalldir clientInstallFlags + + installdir <- fromFlagOrDefault (die' verbosity installdirUnknown) $ + pure <$> cinstInstalldir clientInstallFlags createDirectoryIfMissingVerbose verbosity False installdir warnIfNoExes verbosity buildCtx let doInstall = installUnitExes verbosity overwritePolicy - mkUnitBinDir mkExeName + mkUnitBinDir mkExeName mkFinalExeName installdir installMethod in traverse_ doInstall $ Map.toList $ targetsMap buildCtx where - overwritePolicy = fromFlagOrDefault NeverOverwrite - $ cinstOverwritePolicy clientInstallFlags - installMethod = fromFlagOrDefault InstallMethodSymlink - $ cinstInstallMethod clientInstallFlags + overwritePolicy = fromFlagOrDefault NeverOverwrite $ + cinstOverwritePolicy clientInstallFlags + installMethod = fromFlagOrDefault InstallMethodSymlink $ + cinstInstallMethod clientInstallFlags -- | Install any built library by adding it to the default ghc environment -installLibraries :: Verbosity - -> ProjectBuildContext - -> Compiler - -> PackageDBStack - -> ProgramDb - -> FilePath -- ^ Environment file - -> [GhcEnvironmentFileEntry] - -> IO () +installLibraries + :: Verbosity + -> ProjectBuildContext + -> Compiler + -> PackageDBStack + -> ProgramDb + -> FilePath -- ^ Environment file + -> [GhcEnvironmentFileEntry] + -> IO () installLibraries verbosity buildCtx compiler packageDbs programDb envFile envEntries = do -- Why do we get it again? If we updated a globalPackage then we need @@ -627,7 +689,8 @@ if supportsPkgEnvFiles $ getImplInfo compiler then do let - getLatest = fmap (head . snd) . take 1 . sortBy (comparing (Down . fst)) + getLatest :: PackageName -> [InstalledPackageInfo] + getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) . PI.lookupPackageName installedIndex globalLatest = concat (getLatest <$> globalPackages) @@ -650,19 +713,19 @@ warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () warnIfNoExes verbosity buildCtx = when noExes $ - warn verbosity $ "You asked to install executables, " - <> "but there are no executables in " - <> plural (listPlural selectors) "target" "targets" <> ": " - <> intercalate ", " (showTargetSelector <$> selectors) <> ". " - <> "Perhaps you want to use --lib " - <> "to install libraries instead." + warn verbosity $ + "You asked to install executables, but there are no executables in " + <> plural (listPlural selectors) "target" "targets" <> ": " + <> intercalate ", " (showTargetSelector <$> selectors) <> ". " + <> "Perhaps you want to use --lib to install libraries instead." where - targets = concat $ Map.elems $ targetsMap buildCtx + targets = concat $ Map.elems $ targetsMap buildCtx components = fst <$> targets - selectors = concatMap snd targets - noExes = null $ catMaybes $ exeMaybe <$> components + selectors = concatMap snd targets + noExes = null $ catMaybes $ exeMaybe <$> components + exeMaybe (ComponentTarget (CExeName exe) _) = Just exe - exeMaybe _ = Nothing + exeMaybe _ = Nothing globalPackages :: [PackageName] globalPackages = mkPackageName <$> @@ -673,13 +736,16 @@ , "bin-package-db" ] -environmentFileToSpecifiers :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] - -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) +environmentFileToSpecifiers + :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] + -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) environmentFileToSpecifiers ipi = foldMap $ \case (GhcEnvFilePackageId unitId) - | Just InstalledPackageInfo{ sourcePackageId = PackageIdentifier{..}, installedUnitId } + | Just InstalledPackageInfo + { sourcePackageId = PackageIdentifier{..}, installedUnitId } <- PI.lookupUnitId ipi unitId - , let pkgSpec = NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] + , let pkgSpec = NamedPackage pkgName + [PackagePropertyVersion (thisVersion pkgVersion)] -> if pkgName `elem` globalPackages then ([pkgSpec], []) else ([pkgSpec], [GhcEnvFilePackageId installedUnitId]) @@ -693,19 +759,23 @@ , configBenchmarks = Flag False <> configBenchmarks configFlags } -- | Symlink/copy every exe from a package from the store to a given location -installUnitExes :: Verbosity - -> OverwritePolicy -- ^ Whether to overwrite existing files - -> (UnitId -> FilePath) -- ^ A function to get an UnitId's - -- store directory - -> (UnqualComponentName -> FilePath) -- ^ A function to get - -- ^ an exe's filename - -> FilePath - -> InstallMethod - -> ( UnitId - , [(ComponentTarget, [TargetSelector])] ) - -> IO () +installUnitExes + :: Verbosity + -> OverwritePolicy -- ^ Whether to overwrite existing files + -> (UnitId -> FilePath) -- ^ A function to get an UnitId's + -- ^ store directory + -> (UnqualComponentName -> FilePath) -- ^ A function to get an + -- ^ exe's filename + -> (UnqualComponentName -> FilePath) -- ^ A function to get an + -- ^ exe's final possibly + -- ^ different to the name in the store. + -> FilePath + -> InstallMethod + -> ( UnitId + , [(ComponentTarget, [TargetSelector])] ) + -> IO () installUnitExes verbosity overwritePolicy - mkSourceBinDir mkExeName + mkSourceBinDir mkExeName mkFinalExeName installdir installMethod (unit, components) = traverse_ installAndWarn exes @@ -717,38 +787,42 @@ success <- installBuiltExe verbosity overwritePolicy (mkSourceBinDir unit) (mkExeName exe) + (mkFinalExeName exe) installdir installMethod let errorMessage = case overwritePolicy of - NeverOverwrite -> - "Path '" <> (installdir prettyShow exe) <> "' already exists. " - <> "Use --overwrite-policy=always to overwrite." - -- This shouldn't even be possible, but we keep it in case - -- symlinking/copying logic changes - AlwaysOverwrite -> case installMethod of - InstallMethodSymlink -> "Symlinking" - InstallMethodCopy -> "Copying" - <> " '" <> prettyShow exe <> "' failed." + NeverOverwrite -> + "Path '" <> (installdir prettyShow exe) <> "' already exists. " + <> "Use --overwrite-policy=always to overwrite." + -- This shouldn't even be possible, but we keep it in case + -- symlinking/copying logic changes + AlwaysOverwrite -> + case installMethod of + InstallMethodSymlink -> "Symlinking" + InstallMethodCopy -> + "Copying" <> " '" <> prettyShow exe <> "' failed." unless success $ die' verbosity errorMessage -- | Install a specific exe. -installBuiltExe :: Verbosity -> OverwritePolicy - -> FilePath -- ^ The directory where the built exe is located - -> FilePath -- ^ The exe's filename - -> FilePath -- ^ the directory where it should be installed - -> InstallMethod - -> IO Bool -- ^ Whether the installation was successful +installBuiltExe + :: Verbosity -> OverwritePolicy + -> FilePath -- ^ The directory where the built exe is located + -> FilePath -- ^ The exe's filename + -> FilePath -- ^ The exe's filename in the public install directory + -> FilePath -- ^ the directory where it should be installed + -> InstallMethod + -> IO Bool -- ^ Whether the installation was successful installBuiltExe verbosity overwritePolicy - sourceDir exeName + sourceDir exeName finalExeName installdir InstallMethodSymlink = do notice verbosity $ "Symlinking '" <> exeName <> "'" symlinkBinary overwritePolicy installdir sourceDir - (mkUnqualComponentName exeName) + finalExeName exeName installBuiltExe verbosity overwritePolicy - sourceDir exeName + sourceDir exeName finalExeName installdir InstallMethodCopy = do notice verbosity $ "Copying '" <> exeName <> "'" exists <- doesPathExist destination @@ -758,7 +832,7 @@ (False, _ ) -> copy where source = sourceDir exeName - destination = installdir exeName + destination = installdir finalExeName remove = do isDir <- doesDirectoryExist destination if isDir @@ -774,7 +848,9 @@ hasLib (ComponentTarget (CLibName _) _, _) = True hasLib _ = False - go :: UnitId -> [(ComponentTarget, [TargetSelector])] -> [GhcEnvironmentFileEntry] + go :: UnitId + -> [(ComponentTarget, [TargetSelector])] + -> [GhcEnvironmentFileEntry] go unitId targets | any hasLib targets = [GhcEnvFilePackageId unitId] | otherwise = [] @@ -845,8 +921,9 @@ -- and disabled tests\/benchmarks, fail if there are no such -- components -- -selectPackageTargets :: TargetSelector - -> [AvailableTarget k] -> Either TargetProblem [k] +selectPackageTargets + :: TargetSelector + -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets -- If there are any buildable targets then we select those @@ -878,8 +955,9 @@ -- -- For the @build@ command we just need the basic checks on being buildable etc. -- -selectComponentTarget :: SubComponentTarget - -> AvailableTarget k -> Either TargetProblem k +selectComponentTarget + :: SubComponentTarget + -> AvailableTarget k -> Either TargetProblem k selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right . selectComponentTargetBasic subtarget diff --git a/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/Distribution/Client/CmdInstall/ClientInstallFlags.hs --- a/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -25,13 +25,15 @@ deriving (Eq, Show, Generic, Bounded, Enum) instance Binary InstallMethod +instance Structured InstallMethod data ClientInstallFlags = ClientInstallFlags - { cinstInstallLibs :: Flag Bool + { cinstInstallLibs :: Flag Bool + , cinstIgnoreProject :: Flag Bool , cinstEnvironmentPath :: Flag FilePath , cinstOverwritePolicy :: Flag OverwritePolicy - , cinstInstallMethod :: Flag InstallMethod - , cinstInstalldir :: Flag FilePath + , cinstInstallMethod :: Flag InstallMethod + , cinstInstalldir :: Flag FilePath } deriving (Eq, Show, Generic) instance Monoid ClientInstallFlags where @@ -42,14 +44,16 @@ (<>) = gmappend instance Binary ClientInstallFlags +instance Structured ClientInstallFlags defaultClientInstallFlags :: ClientInstallFlags defaultClientInstallFlags = ClientInstallFlags - { cinstInstallLibs = toFlag False + { cinstInstallLibs = toFlag False + , cinstIgnoreProject = toFlag False , cinstEnvironmentPath = mempty , cinstOverwritePolicy = mempty - , cinstInstallMethod = mempty - , cinstInstalldir = mempty + , cinstInstallMethod = mempty + , cinstInstalldir = mempty } clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags] @@ -58,6 +62,10 @@ "Install libraries rather than executables from the target package." cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v }) trueArg + , option "z" ["ignore-project"] + "Ignore local project configuration" + cinstIgnoreProject (\v flags -> flags { cinstIgnoreProject = v }) + trueArg , option [] ["package-env", "env"] "Set the environment file that may be modified." cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf }) @@ -103,4 +111,3 @@ showInstallMethodFlag (Flag InstallMethodCopy) = ["copy"] showInstallMethodFlag (Flag InstallMethodSymlink) = ["symlink"] showInstallMethodFlag NoFlag = [] - diff --git a/Distribution/Client/CmdLegacy.hs b/Distribution/Client/CmdLegacy.hs --- a/Distribution/Client/CmdLegacy.hs +++ b/Distribution/Client/CmdLegacy.hs @@ -68,6 +68,9 @@ instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where verbosity (a, _, _, _, _) = verbosity a +instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where + verbosity (a, _, _, _, _, _) = verbosity a + instance HasVerbosity Setup.BuildFlags where verbosity = verbosity . Setup.buildVerbosity @@ -108,22 +111,22 @@ "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ "It is a legacy feature and will be removed in a future release of cabal-install." ++ - " Please file a bug if you cannot replicate a working v1- use case with the new-style" ++ + " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++ " commands.\n\n" ++ - "For more information, see: https://wiki.haskell.org/Cabal/NewBuild\n" + "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html" toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)] toLegacyCmd mkSpec = [toLegacy mkSpec] - where - toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' - where - legUi = origUi - { commandName = "v1-" ++ commandName - , commandNotes = Just $ \pname -> case commandNotes of - Just notes -> notes pname ++ "\n" ++ legacyNote commandName - Nothing -> legacyNote commandName - } + where + toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' + where + legUi = origUi + { commandName = "v1-" ++ commandName + , commandNotes = Just $ \pname -> case commandNotes of + Just notes -> notes pname ++ "\n" ++ legacyNote commandName + Nothing -> legacyNote commandName + } legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] legacyCmd ui action = toLegacyCmd (regularCmd ui action) diff --git a/Distribution/Client/CmdRepl.hs b/Distribution/Client/CmdRepl.hs --- a/Distribution/Client/CmdRepl.hs +++ b/Distribution/Client/CmdRepl.hs @@ -30,22 +30,21 @@ import Distribution.Client.ProjectBuilding ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) import Distribution.Client.ProjectConfig - ( ProjectConfig(..), withProjectOrGlobalConfig - , projectConfigConfigFile, readGlobalConfig ) + ( ProjectConfig(..), withProjectOrGlobalConfigIgn + , projectConfigConfigFile ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) import Distribution.Client.ProjectPlanning.Types ( elabOrderExeDependencies ) -import Distribution.Client.RebuildMonad - ( runRebuild ) import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Client.Types ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault, replOptions + ( HaddockFlags, TestFlags, BenchmarkFlags + , fromFlagOrDefault, replOptions , Flag(..), toFlag, trueArg, falseArg ) import Distribution.Simple.Command ( CommandUI(..), liftOption, usageAlternatives, option @@ -90,6 +89,8 @@ ( anyVersion ) import Distribution.Deprecated.Text ( display ) +import Distribution.Utils.Generic + ( safeHead ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils @@ -143,7 +144,10 @@ ("couldn't parse dependency: " ++) (parsecCommaList parsec) -replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ReplFlags, EnvFlags) +replCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + , ReplFlags, EnvFlags + ) replCommand = Client.installCommand { commandName = "v2-repl", commandSynopsis = "Open an interactive session for the given component.", @@ -181,27 +185,31 @@ ++ "to the default component (or no component if there is no project present)\n" ++ cmdCommonHelpTextNewBuildBeta, - commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,testFlags,[],defaultEnvFlags), + commandDefaultFlags = ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags + , [], defaultEnvFlags + ), commandOptions = \showOrParseArgs -> map liftOriginal (commandOptions Client.installCommand showOrParseArgs) ++ map liftReplOpts (replOptions showOrParseArgs) ++ map liftEnvOpts (envOptions showOrParseArgs) } where - (configFlags,configExFlags,installFlags,haddockFlags,testFlags) = commandDefaultFlags Client.installCommand + (configFlags,configExFlags,installFlags,haddockFlags,testFlags,benchmarkFlags) + = commandDefaultFlags Client.installCommand liftOriginal = liftOption projectOriginal updateOriginal liftReplOpts = liftOption projectReplOpts updateReplOpts liftEnvOpts = liftOption projectEnvOpts updateEnvOpts - projectOriginal (a,b,c,d,e,_,_) = (a,b,c,d,e) - updateOriginal (a,b,c,d,e) (_,_,_,_,_,f,g) = (a,b,c,d,e,f,g) + projectOriginal (a,b,c,d,e,f,_,_) = (a,b,c,d,e,f) + updateOriginal (a,b,c,d,e,f) (_,_,_,_,_,_,g,h) = (a,b,c,d,e,f,g,h) - projectReplOpts (_,_,_,_,_,f,_) = f - updateReplOpts f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g) + projectReplOpts (_,_,_,_,_,_,g,_) = g + updateReplOpts g (a,b,c,d,e,f,_,h) = (a,b,c,d,e,f,g,h) - projectEnvOpts (_,_,_,_,_,_,g) = g - updateEnvOpts g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) + projectEnvOpts (_,_,_,_,_,_,_,h) = h + updateEnvOpts h (a,b,c,d,e,f,g,_) = (a,b,c,d,e,f,g,h) -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit @@ -214,20 +222,21 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ReplFlags, EnvFlags) +replAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + , ReplFlags, EnvFlags ) -> [String] -> GlobalFlags -> IO () -replAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, replFlags, envFlags) +replAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags + , replFlags, envFlags ) targetStrings globalFlags = do let ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags) with = withProject cliConfig verbosity targetStrings without config = withoutProject (config <> cliConfig) verbosity targetStrings - (baseCtx, targetSelectors, finalizer, replType) <- if ignoreProject - then do - globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag - without globalConfig - else withProjectOrGlobalConfig verbosity globalConfigFlag with without + (baseCtx, targetSelectors, finalizer, replType) <- + withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag with without when (buildSettingOnlyDeps (buildSettings baseCtx)) $ die' verbosity $ "The repl command does not support '--only-dependencies'. " @@ -241,13 +250,14 @@ -- help us resolve the targets, but that isn't ideal for performance, -- especially in the no-project case. withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do + -- targets should be non-empty map, but there's no NonEmptyMap yet. targets <- validatedTargets elaboratedPlan targetSelectors let - (unitId, _) = head $ Map.toList targets + (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId oci = OriginalComponentInfo unitId originalDeps - Just pkgId = packageId <$> InstallPlan.lookup elaboratedPlan unitId + pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx return (Just oci, baseCtx') @@ -322,7 +332,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) validatedTargets elaboratedPlan targetSelectors = do diff --git a/Distribution/Client/CmdRun.hs b/Distribution/Client/CmdRun.hs --- a/Distribution/Client/CmdRun.hs +++ b/Distribution/Client/CmdRun.hs @@ -18,20 +18,25 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Client.Compat.Prelude hiding (toList) import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages +import Distribution.Client.CmdRun.ClientRunFlags + import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) + , configureExOptions, haddockOptions, installOptions, testOptions + , benchmarkOptions, configureOptions, liftOptions ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(..) ) import Distribution.Client.GlobalFlags ( defaultGlobalFlags ) -import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI(..), OptionField (..), usageAlternatives ) import Distribution.Types.ComponentName ( showComponentName ) import Distribution.Deprecated.Text @@ -45,7 +50,7 @@ ( establishDummyProjectBaseContext ) import Distribution.Client.ProjectConfig ( ProjectConfig(..), ProjectConfigShared(..) - , withProjectOrGlobalConfig ) + , withProjectOrGlobalConfigIgn ) import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage(..) , ElaboratedInstallPlan, binDirectoryFor ) @@ -107,44 +112,77 @@ ( (), isValid, isPathSeparator, takeExtension ) -runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) -runCommand = Client.installCommand { - commandName = "v2-run", - commandSynopsis = "Run an executable.", - commandUsage = usageAlternatives "v2-run" - [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ], - commandDescription = Just $ \pname -> wrapText $ - "Runs the specified executable-like component (an executable, a test, " - ++ "or a benchmark), first ensuring it is up to date.\n\n" +runCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + , ClientRunFlags + ) +runCommand = CommandUI + { commandName = "v2-run" + , commandSynopsis = "Run an executable." + , commandUsage = usageAlternatives "v2-run" + [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ] + , commandDescription = Just $ \pname -> wrapText $ + "Runs the specified executable-like component (an executable, a test, " + ++ "or a benchmark), first ensuring it is up to date.\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" + ++ "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 - ++ ". The executable is run in an environment where it can find its " - ++ "data files inplace in the build tree.\n\n" + ++ "Extra arguments can be passed to the program, but use '--' to " + ++ "separate arguments for the program from arguments for " ++ pname + ++ ". The executable is run in an environment where it can find its " + ++ "data files inplace in the build tree.\n\n" - ++ "Dependencies are built or rebuilt as necessary. Additional " - ++ "configuration flags can be specified on the command line and these " - ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " v2-run\n" - ++ " Run the executable-like in the package in the current directory\n" - ++ " " ++ pname ++ " v2-run foo-tool\n" - ++ " Run the named executable-like (in any package in the project)\n" - ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" - ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" - ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" - ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" + ++ "Dependencies are built or rebuilt as necessary. Additional " + ++ "configuration flags can be specified on the command line and these " + ++ "extend the project configuration from the 'cabal.project', " + ++ "'cabal.project.local' and other files." + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v2-run\n" + ++ " Run the executable-like in the package in the current directory\n" + ++ " " ++ pname ++ " v2-run foo-tool\n" + ++ " Run the named executable-like (in any package in the project)\n" + ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n" + ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n" + ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n" + ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" - ++ cmdCommonHelpTextNewBuildBeta + ++ cmdCommonHelpTextNewBuildBeta + , commandDefaultFlags = (mempty, mempty, mempty, 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 + -- hide "target-package-db" flag from the + -- install options. + (filter ((`notElem` ["target-package-db"]) + . optionName) $ + installOptions showOrParseArgs) + ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) + ++ liftOptions get5 set5 (testOptions showOrParseArgs) + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) + ++ liftOptions get7 set7 (clientRunOptions showOrParseArgs) } + where + get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g) + get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g) + get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g) + get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g) + get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g) + get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g) + get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) + -- | 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 @@ -153,9 +191,13 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +runAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + , ClientRunFlags ) -> [String] -> GlobalFlags -> IO () -runAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +runAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags + , clientRunFlags ) targetStrings globalFlags = do globalTmp <- getTemporaryDirectory tempDir <- createTempDirectory globalTmp "cabal-repl." @@ -166,8 +208,11 @@ without config = establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] OtherCommand - baseCtx <- withProjectOrGlobalConfig verbosity globalConfigFlag with without + let + ignoreProject = fromFlagOrDefault False (crunIgnoreProject clientRunFlags) + baseCtx <- withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag with without + let scriptOrError script err = do exists <- doesFileExist script @@ -299,7 +344,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -- | Used by the main CLI parser as heuristic to decide whether @cabal@ was diff --git a/Distribution/Client/CmdRun/ClientRunFlags.hs b/Distribution/Client/CmdRun/ClientRunFlags.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdRun/ClientRunFlags.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +module Distribution.Client.CmdRun.ClientRunFlags +( ClientRunFlags(..) +, defaultClientRunFlags +, clientRunOptions +) where + +import Distribution.Client.Compat.Prelude + +import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option) +import Distribution.Simple.Setup (Flag (..), toFlag, trueArg) + +data ClientRunFlags = ClientRunFlags + { crunIgnoreProject :: Flag Bool + } deriving (Eq, Show, Generic) + +instance Monoid ClientRunFlags where + mempty = gmempty + mappend = (<>) + +instance Semigroup ClientRunFlags where + (<>) = gmappend + +instance Binary ClientRunFlags +instance Structured ClientRunFlags + +defaultClientRunFlags :: ClientRunFlags +defaultClientRunFlags = ClientRunFlags + { crunIgnoreProject = toFlag False + } + +clientRunOptions :: ShowOrParseArgs -> [OptionField ClientRunFlags] +clientRunOptions _ = + [ option "z" ["ignore-project"] + "Ignore local project configuration" + crunIgnoreProject (\v flags -> flags { crunIgnoreProject = v }) + trueArg + ] diff --git a/Distribution/Client/CmdSdist.hs b/Distribution/Client/CmdSdist.hs --- a/Distribution/Client/CmdSdist.hs +++ b/Distribution/Client/CmdSdist.hs @@ -9,6 +9,9 @@ , SdistFlags(..), defaultSdistFlags , OutputFormat(..)) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.CmdErrorMessages ( Plural(..), renderComponentKind ) import Distribution.Client.ProjectOrchestration @@ -29,9 +32,6 @@ import Distribution.Client.ProjectConfig ( findProjectRoot, readProjectConfig ) -import Distribution.Compat.Semigroup - ((<>)) - import Distribution.Package ( Package(packageId) ) import Distribution.PackageDescription.Configuration @@ -64,8 +64,6 @@ import qualified Codec.Compression.GZip as GZip import Control.Exception ( throwIO ) -import Control.Monad - ( when, forM_ ) import Control.Monad.Trans ( liftIO ) import Control.Monad.State.Lazy @@ -77,7 +75,7 @@ import Data.Either ( partitionEithers ) import Data.List - ( find, sortOn, nub ) + ( sortOn ) import qualified Data.Set as Set import System.Directory ( getCurrentDirectory, setCurrentDirectory @@ -192,7 +190,7 @@ | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> die' verbosity "Can't write multiple tarballs to standard output!" | otherwise -> - mapM_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs + traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs data IsExec = Exec | NoExec deriving (Show, Eq) @@ -256,7 +254,7 @@ Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) Right path -> tell [Tar.directoryEntry path] - forM_ files $ \(perm, file) -> do + for_ files $ \(perm, file) -> do let fileDir = takeDirectory (prefix file) perm' = case perm of Exec -> Tar.executableFilePermissions @@ -276,9 +274,9 @@ entries <- execWriterT (evalStateT entriesM mempty) let -- Pretend our GZip file is made on Unix. - normalize bs = BSL.concat [first, "\x03", rest'] + normalize bs = BSL.concat [pfx, "\x03", rest'] where - (first, rest) = BSL.splitAt 9 bs + (pfx, rest) = BSL.splitAt 9 bs rest' = BSL.tail rest -- The Unix epoch, which is the default value, is -- unsuitable because it causes unpacking problems on diff --git a/Distribution/Client/CmdTest.hs b/Distribution/Client/CmdTest.hs --- a/Distribution/Client/CmdTest.hs +++ b/Distribution/Client/CmdTest.hs @@ -20,7 +20,7 @@ ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup - ( HaddockFlags, TestFlags(..), fromFlagOrDefault ) + ( HaddockFlags, TestFlags(..), BenchmarkFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Flag @@ -36,7 +36,9 @@ import qualified System.Exit (exitSuccess) -testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +testCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) testCommand = Client.installCommand { commandName = "v2-test" , commandSynopsis = "Run test-suites" @@ -84,9 +86,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +testAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -testAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +testAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand @@ -131,7 +135,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @test@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/Distribution/Client/CmdUpdate.hs b/Distribution/Client/CmdUpdate.hs --- a/Distribution/Client/CmdUpdate.hs +++ b/Distribution/Client/CmdUpdate.hs @@ -36,7 +36,7 @@ , UpdateFlags, defaultUpdateFlags , RepoContext(..) ) import Distribution.Simple.Setup - ( HaddockFlags, TestFlags, fromFlagOrDefault ) + ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) import Distribution.Verbosity @@ -64,7 +64,9 @@ import qualified Hackage.Security.Client as Sec updateCommand :: CommandUI ( ConfigFlags, ConfigExFlags - , InstallFlags, HaddockFlags, TestFlags ) + , InstallFlags, HaddockFlags + , TestFlags, BenchmarkFlags + ) updateCommand = Client.installCommand { commandName = "v2-update", commandSynopsis = "Updates list of known packages.", @@ -114,9 +116,11 @@ name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof return (UpdateRequest name IndexStateHead) -updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +updateAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO () -updateAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags) +updateAction ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do projectConfig <- withProjectOrGlobalConfig verbosity globalConfigFlag (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand) @@ -174,7 +178,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) @@ -182,7 +186,8 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do transport <- repoContextGetTransport repoCtxt case repo of - RepoLocal{..} -> return () + RepoLocal{} -> return () + RepoLocalNoIndex{} -> return () RepoRemote{..} -> do downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir diff --git a/Distribution/Client/Compat/FileLock.hsc b/Distribution/Client/Compat/FileLock.hsc deleted file mode 100644 --- a/Distribution/Client/Compat/FileLock.hsc +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE InterruptibleFFI #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum --- required version. Though note that the locking functionality is not in --- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module. -module Distribution.Client.Compat.FileLock ( - FileLockingNotSupported(..) - , LockMode(..) - , hLock - , hTryLock - ) where - -#if MIN_VERSION_base(4,10,0) - -import GHC.IO.Handle.Lock - -#else - --- The remainder of this file is a modified copy --- of GHC.IO.Handle.Lock from ghc-8.2.x --- --- The modifications were just to the imports and the CPP, since we do not have --- access to the HAVE_FLOCK from the ./configure script. We approximate the --- lack of HAVE_FLOCK with defined(solaris2_HOST_OS) instead since that is the --- only known major Unix platform lacking flock(). - -import Control.Exception (Exception) -import Data.Typeable - -#if defined(solaris2_HOST_OS) - -import Control.Exception (throwIO) -import System.IO (Handle) - -#else - -import Data.Bits -import Data.Function -import Control.Concurrent.MVar - -import Foreign.C.Error -import Foreign.C.Types - -import GHC.IO.Handle.Types -import GHC.IO.FD -import GHC.IO.Exception - -#if defined(mingw32_HOST_OS) - -#if defined(i386_HOST_ARCH) -## define WINDOWS_CCONV stdcall -#elif defined(x86_64_HOST_ARCH) -## define WINDOWS_CCONV ccall -#else -# error Unknown mingw32 arch -#endif - -#include - -import Foreign.Marshal.Alloc -import Foreign.Marshal.Utils -import Foreign.Ptr -import GHC.Windows - -#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ - -#include - -#endif /* !defined(mingw32_HOST_OS) */ - -#endif /* !defined(solaris2_HOST_OS) */ - - --- | 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 - --- | If a 'Handle' references a file descriptor, attempt to lock contents of the --- underlying file in appropriate mode. If the file is already locked in --- incompatible mode, this function blocks until the lock is established. The --- lock is automatically released upon closing a 'Handle'. --- --- Things to be aware of: --- --- 1) This function may block inside a C call. If it does, in order to be able --- to interrupt it with asynchronous exceptions and/or for other threads to --- continue working, you MUST use threaded version of the runtime system. --- --- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise, --- hence all of their caveats also apply here. --- --- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this --- function throws 'FileLockingNotImplemented'. We deliberately choose to not --- provide fcntl based locking instead because of its broken semantics. --- --- @since 4.10.0.0 -hLock :: Handle -> LockMode -> IO () -hLock h mode = lockImpl h "hLock" mode True >> return () - --- | Non-blocking version of 'hLock'. --- --- @since 4.10.0.0 -hTryLock :: Handle -> LockMode -> IO Bool -hTryLock h mode = lockImpl h "hTryLock" mode False - ----------------------------------------- - -#if defined(solaris2_HOST_OS) - --- | No-op implementation. -lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl _ _ _ _ = throwIO FileLockingNotSupported - -#else /* !defined(solaris2_HOST_OS) */ - -#if defined(mingw32_HOST_OS) - -lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl h ctx mode block = do - FD{fdFD = fd} <- handleToFd h - wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd - allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do - fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0 - let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY}) - -- We want to lock the whole file without looking up its size to be - -- consistent with what flock does. According to documentation of LockFileEx - -- "locking a region that goes beyond the current end-of-file position is - -- not an error", however e.g. Windows 10 doesn't accept maximum possible - -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by - -- trying 2^32-1. - fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \case - True -> return True - False -> getLastError >>= \err -> if - | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False - | err == #{const ERROR_OPERATION_ABORTED} -> retry - | otherwise -> failWith ctx err - where - sizeof_OVERLAPPED = #{size OVERLAPPED} - - cmode = case mode of - SharedLock -> 0 - ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK} - --- https://msdn.microsoft.com/en-us/library/aa297958.aspx -foreign import ccall unsafe "_get_osfhandle" - c_get_osfhandle :: CInt -> IO HANDLE - --- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx -foreign import WINDOWS_CCONV interruptible "LockFileEx" - c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL - -#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */ - -lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool -lockImpl h ctx mode block = do - FD{fdFD = fd} <- handleToFd h - let flags = cmode .|. (if block then 0 else #{const LOCK_NB}) - fix $ \retry -> c_flock fd flags >>= \case - 0 -> return True - _ -> getErrno >>= \errno -> if - | not block && errno == eWOULDBLOCK -> return False - | errno == eINTR -> retry - | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing - where - cmode = case mode of - SharedLock -> #{const LOCK_SH} - ExclusiveLock -> #{const LOCK_EX} - -foreign import ccall interruptible "flock" - c_flock :: CInt -> CInt -> IO CInt - -#endif /* !defined(mingw32_HOST_OS) */ - --- | Turn an existing Handle into a file descriptor. This function throws an --- IOError if the Handle does not reference a file descriptor. -handleToFd :: Handle -> IO FD -handleToFd h = case h of - FileHandle _ mv -> do - Handle__{haDevice = dev} <- readMVar mv - case cast dev of - Just fd -> return fd - Nothing -> throwErr "not a file descriptor" - DuplexHandle{} -> throwErr "not a file handle" - where - throwErr msg = ioException $ IOError (Just h) - InappropriateType "handleToFd" msg Nothing Nothing - -#endif /* defined(solaris2_HOST_OS) */ - -#endif /* MIN_VERSION_base */ diff --git a/Distribution/Client/Compat/Orphans.hs b/Distribution/Client/Compat/Orphans.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Compat/Orphans.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Distribution.Client.Compat.Orphans () where + +import Control.Exception (SomeException) +import Distribution.Compat.Binary (Binary (..)) +import Distribution.Compat.Typeable (typeRep) +import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) +import Network.URI (URI (..), URIAuth (..)) + +------------------------------------------------------------------------------- +-- network-uri +------------------------------------------------------------------------------- + +-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier +-- versions do not, so we use manual Binary instances here +instance Binary URI where + put (URI a b c d e) = do put a; put b; put c; put d; put e + get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get + return (URI a b c d e) + +instance Structured URI where + structure p = Nominal (typeRep p) 0 "URI" [] + +instance Binary URIAuth where + put (URIAuth a b c) = do put a; put b; put c + get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) + +------------------------------------------------------------------------------- +-- base +------------------------------------------------------------------------------- + +--FIXME: Duncan Coutts: this is a total cheat +--Added in 46aa019ec85e313e257d122a3549cce01996c566 +instance Binary SomeException where + put _ = return () + get = fail "cannot serialise exceptions" + +instance Structured SomeException where + structure p = Nominal (typeRep p) 0 "SomeException" [] diff --git a/Distribution/Client/Compat/Prelude.hs b/Distribution/Client/Compat/Prelude.hs --- a/Distribution/Client/Compat/Prelude.hs +++ b/Distribution/Client/Compat/Prelude.hs @@ -17,3 +17,4 @@ import Prelude (IO) import Distribution.Compat.Prelude.Internal hiding (IO) +import Distribution.Client.Compat.Orphans () 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 @@ -12,6 +12,8 @@ import Control.Exception (mask_, onException) import Control.Monad (join, unless) import Data.Typeable (Typeable) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE -- | 'QSem' is a quantity semaphore in which the resource is aqcuired -- and released in units of one. It provides guaranteed FIFO ordering @@ -97,8 +99,8 @@ checkwake2 [] = do writeTVar q 1 return (return ()) - checkwake2 ys = do - let (z:zs) = reverse ys + checkwake2 (y:ys) = do + let (z:|zs) = NE.reverse (y:|ys) writeTVar b1 zs writeTVar b2 [] return (wake s z) diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -41,7 +41,8 @@ userConfigUpdate, createDefaultConfigFile, - remoteRepoFields + remoteRepoFields, + postProcessRepo, ) where import Language.Haskell.Extension ( Language(Haskell2010) ) @@ -50,7 +51,7 @@ ( viewAsFieldDescr ) import Distribution.Client.Types - ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo + ( RemoteRepo(..), LocalRepo (..), Username(..), Password(..), emptyRemoteRepo , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps ) import Distribution.Client.BuildReports.Types @@ -64,7 +65,7 @@ , InstallFlags(..), installOptions, defaultInstallFlags , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand - , showRepo, parseRepo, readRepo ) + , showRemoteRepo, parseRemoteRepo, readRemoteRepo ) import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..), defaultClientInstallFlags , clientInstallOptions ) @@ -79,6 +80,7 @@ ( ConfigFlags(..), configureOptions, defaultConfigFlags , HaddockFlags(..), haddockOptions, defaultHaddockFlags , TestFlags(..), defaultTestFlags + , BenchmarkFlags(..), defaultBenchmarkFlags , installDirsOptions, optionDistPref , programDbPaths', programDbOptions , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) @@ -91,7 +93,7 @@ , locatedErrorMsg, showPWarning , readFields, warning, lineNo , simpleField, listField, spaceListField - , parseFilePathQ, parseOptCommaList, parseTokenQ ) + , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError) import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) import Distribution.Client.HttpUtils @@ -169,7 +171,8 @@ savedUploadFlags :: UploadFlags, savedReportFlags :: ReportFlags, savedHaddockFlags :: HaddockFlags, - savedTestFlags :: TestFlags + savedTestFlags :: TestFlags, + savedBenchmarkFlags :: BenchmarkFlags } deriving Generic instance Monoid SavedConfig where @@ -189,7 +192,8 @@ savedUploadFlags = combinedSavedUploadFlags, savedReportFlags = combinedSavedReportFlags, savedHaddockFlags = combinedSavedHaddockFlags, - savedTestFlags = combinedSavedTestFlags + savedTestFlags = combinedSavedTestFlags, + savedBenchmarkFlags = combinedSavedBenchmarkFlags } where -- This is ugly, but necessary. If we're mappending two config files, we @@ -225,7 +229,8 @@ in case b' of [] -> a' _ -> b' - lastNonMempty' :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a + lastNonMempty' + :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a lastNonMempty' field subfield = let a' = subfield . field $ a b' = subfield . field $ b @@ -248,6 +253,7 @@ globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, globalCacheDir = combine globalCacheDir, globalLocalRepos = lastNonEmptyNL globalLocalRepos, + globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, globalLogsDir = combine globalLogsDir, globalWorldFile = combine globalWorldFile, globalRequireSandbox = combine globalRequireSandbox, @@ -306,6 +312,7 @@ installMaxBackjumps = combine installMaxBackjumps, installReorderGoals = combine installReorderGoals, installCountConflicts = combine installCountConflicts, + installFineGrainedConflicts = combine installFineGrainedConflicts, installMinimizeConflictSet = combine installMinimizeConflictSet, installIndependentGoals = combine installIndependentGoals, installShadowPkgs = combine installShadowPkgs, @@ -337,12 +344,13 @@ combine = combine' savedInstallFlags lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags - combinedSavedClientInstallFlags = ClientInstallFlags { - cinstInstallLibs = combine cinstInstallLibs, - cinstEnvironmentPath = combine cinstEnvironmentPath, - cinstOverwritePolicy = combine cinstOverwritePolicy, - cinstInstallMethod = combine cinstInstallMethod, - cinstInstalldir = combine cinstInstalldir + combinedSavedClientInstallFlags = ClientInstallFlags + { cinstInstallLibs = combine cinstInstallLibs + , cinstIgnoreProject = combine cinstIgnoreProject + , cinstEnvironmentPath = combine cinstEnvironmentPath + , cinstOverwritePolicy = combine cinstOverwritePolicy + , cinstInstallMethod = combine cinstInstallMethod + , cinstInstalldir = combine cinstInstalldir } where combine = combine' savedClientInstallFlags @@ -414,7 +422,8 @@ configFlagError = combine configFlagError, configRelocatable = combine configRelocatable, configUseResponseFiles = combine configUseResponseFiles, - configAllowDependingOnPrivateLibs = combine configAllowDependingOnPrivateLibs + configAllowDependingOnPrivateLibs = + combine configAllowDependingOnPrivateLibs } where combine = combine' savedConfigureFlags @@ -429,8 +438,10 @@ -- TODO: NubListify configPreferences = lastNonEmpty configPreferences, configSolver = combine configSolver, - configAllowNewer = combineMonoid savedConfigureExFlags configAllowNewer, - configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder, + configAllowNewer = + combineMonoid savedConfigureExFlags configAllowNewer, + configAllowOlder = + combineMonoid savedConfigureExFlags configAllowOlder, configWriteGhcEnvironmentFilesPolicy = combine configWriteGhcEnvironmentFilesPolicy } @@ -509,7 +520,16 @@ combine = combine' savedTestFlags lastNonEmpty = lastNonEmpty' savedTestFlags + combinedSavedBenchmarkFlags = BenchmarkFlags { + benchmarkDistPref = combine benchmarkDistPref, + benchmarkVerbosity = combine benchmarkVerbosity, + benchmarkOptions = lastNonEmpty benchmarkOptions + } + where + combine = combine' savedBenchmarkFlags + lastNonEmpty = lastNonEmpty' savedBenchmarkFlags + -- -- * Default config -- @@ -724,7 +744,8 @@ minp <- readConfigFile mempty configFile case minp of Nothing -> do - notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "." + notice verbosity $ + "Config file path source is " ++ sourceMsg source ++ "." notice verbosity $ "Config file " ++ configFile ++ " not found." createDefaultConfigFile verbosity [] configFile Just (ParseOk ws conf) -> do @@ -764,7 +785,8 @@ getSource ((source,action): xs) = action >>= maybe (getSource xs) (return . (,) source) -readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) +readConfigFile + :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) readConfigFile initial file = handleNotExists $ fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial) (readFile file) @@ -788,7 +810,8 @@ writeConfigFile file comments vals = do let tmpFile = file <.> "tmp" createDirectoryIfMissing True (takeDirectory file) - writeFile tmpFile $ explanation ++ showConfigWithComments comments vals ++ "\n" + writeFile tmpFile $ + explanation ++ showConfigWithComments comments vals ++ "\n" renameFile tmpFile file where explanation = unlines @@ -843,7 +866,8 @@ savedUploadFlags = commandDefaultFlags uploadCommand, savedReportFlags = commandDefaultFlags reportCommand, savedHaddockFlags = defaultHaddockFlags, - savedTestFlags = defaultTestFlags + savedTestFlags = defaultTestFlags, + savedBenchmarkFlags = defaultBenchmarkFlags } conf1 <- extendToEffectiveConfig conf0 let globalFlagsConf1 = savedGlobalFlags conf1 @@ -901,7 +925,8 @@ | str == "1" -> ParseOk [] (Flag NormalOptimisation) | str == "2" -> ParseOk [] (Flag MaximumOptimisation) | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation) - | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation) + | lstr == "true" -> ParseOk [caseWarning] + (Flag NormalOptimisation) | otherwise -> ParseFailed (NoParse name line) where lstr = lowercase str @@ -937,16 +962,20 @@ ++ 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 }) + [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 @@ -1008,7 +1037,7 @@ deprecatedFieldDescriptions = [ liftGlobalFlag $ listField "repos" - (Disp.text . showRepo) parseRepo + (Disp.text . showRemoteRepo) parseRemoteRepo (fromNubList . globalRemoteRepos) (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) , liftGlobalFlag $ @@ -1031,8 +1060,10 @@ (fromFlagOrDefault [] . uploadPasswordCmd) (\d cfg -> cfg { uploadPasswordCmd = Flag d }) ] - ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields - ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields + ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) + installDirsFields + ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) + installDirsFields where optional = Parse.option mempty . fmap toFlag modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a @@ -1045,8 +1076,9 @@ liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig -liftGlobalInstallDirs = liftField - savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags }) +liftGlobalInstallDirs = + liftField savedGlobalInstallDirs + (\flags conf -> conf { savedGlobalInstallDirs = flags }) liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig liftGlobalFlag = liftField @@ -1065,8 +1097,9 @@ savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig -liftClientInstallFlag = liftField - savedClientInstallFlags (\flags conf -> conf { savedClientInstallFlags = flags }) +liftClientInstallFlag = + liftField savedClientInstallFlags + (\flags conf -> conf { savedClientInstallFlags = flags }) liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig liftUploadFlag = liftField @@ -1087,9 +1120,9 @@ let init0 = savedInitFlags config user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config - (remoteRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- + (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- foldM parseSections - ([], savedHaddockFlags config, init0, user0, global0, [], []) + ([], [], savedHaddockFlags config, init0, user0, global0, [], []) knownSections let remoteRepoSections = @@ -1097,9 +1130,15 @@ . nubBy ((==) `on` remoteRepoName) $ remoteRepoSections0 + let localRepoSections = + reverse + . nubBy ((==) `on` localRepoName) + $ localRepoSections0 + return . fixConfigMultilines $ config { savedGlobalFlags = (savedGlobalFlags config) { globalRemoteRepos = toNubList remoteRepoSections, + globalLocalNoIndexRepos = toNubList localRepoSections, -- the global extra prog path comes from the configure flag prog path globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) }, @@ -1123,86 +1162,89 @@ isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True isKnownSection _ = False - -- attempt to split fields that can represent lists of paths into actual lists - -- on failure, leave the field untouched + -- Attempt to split fields that can represent lists of paths into + -- actual lists on failure, leave the field untouched. splitMultiPath :: [String] -> [String] splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of ParseOk _ res -> res _ -> [s] splitMultiPath xs = xs - -- This is a fixup, pending a full config parser rewrite, to ensure that - -- config fields which can be comma seperated lists actually parse as comma seperated lists + -- This is a fixup, pending a full config parser rewrite, to + -- ensure that config fields which can be comma-separated lists + -- actually parse as comma-separated lists. fixConfigMultilines conf = conf { savedConfigureFlags = let scf = savedConfigureFlags conf in scf { - configProgramPathExtra = toNubList $ splitMultiPath (fromNubList $ configProgramPathExtra scf) - , configExtraLibDirs = splitMultiPath (configExtraLibDirs scf) - , configExtraFrameworkDirs = splitMultiPath (configExtraFrameworkDirs scf) - , configExtraIncludeDirs = splitMultiPath (configExtraIncludeDirs scf) - , configConfigureArgs = splitMultiPath (configConfigureArgs scf) + configProgramPathExtra = + toNubList $ splitMultiPath + (fromNubList $ configProgramPathExtra scf) + , configExtraLibDirs = splitMultiPath + (configExtraLibDirs scf) + , configExtraFrameworkDirs = splitMultiPath + (configExtraFrameworkDirs scf) + , configExtraIncludeDirs = splitMultiPath + (configExtraIncludeDirs scf) + , configConfigureArgs = splitMultiPath + (configConfigureArgs scf) } } parse = parseFields (configFieldDescriptions src ++ deprecatedFieldDescriptions) initial - parseSections (rs, h, i, u, g, p, a) - (ParseUtils.Section _ "repository" name fs) = do + parseSections (rs, ls, h, i, u, g, p, a) + (ParseUtils.Section lineno "repository" name fs) = do r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs - when (remoteRepoKeyThreshold r' > length (remoteRepoRootKeys r')) $ - warning $ "'key-threshold' for repository " ++ show (remoteRepoName r') - ++ " higher than number of keys" - when (not (null (remoteRepoRootKeys r')) - && remoteRepoSecure r' /= Just True) $ - warning $ "'root-keys' for repository " ++ show (remoteRepoName r') - ++ " non-empty, but 'secure' not set to True." - return (r':rs, h, i, u, g, p, a) + r'' <- postProcessRepo lineno name r' + case r'' of + Left local -> return (rs, local:ls, h, i, u, g, p, a) + Right remote -> return (remote:rs, ls, h, i, u, g, p, a) - parseSections (rs, h, i, u, g, p, a) + parseSections (rs, ls, h, i, u, g, p, a) (ParseUtils.F lno "remote-repo" raw) = do - let mr' = readRepo raw + let mr' = readRemoteRepo raw r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr' - return (r':rs, h, i, u, g, p, a) + return (r':rs, ls, h, i, u, g, p, a) - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "haddock" name fs) | name == "" = do h' <- parseFields haddockFlagsFields h fs - return (rs, h', i, u, g, p, a) + return (rs, ls, h', i, u, g, p, a) | otherwise = do warning "The 'haddock' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "init" name fs) | name == "" = do i' <- parseFields initFlagsFields i fs - return (rs, h, i', u, g, p, a) + return (rs, ls, h, i', u, g, p, a) | otherwise = do warning "The 'init' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "install-dirs" name fs) | name' == "user" = do u' <- parseFields installDirsFields u fs - return (rs, h, i, u', g, p, a) + return (rs, ls, h, i, u', g, p, a) | name' == "global" = do g' <- parseFields installDirsFields g fs - return (rs, h, i, u, g', p, a) + return (rs, ls, h, i, u, g', p, a) | otherwise = do warning "The 'install-paths' section should be for 'user' or 'global'" return accum where name' = lowercase name - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "program-locations" name fs) | name == "" = do p' <- parseFields withProgramsFields p fs - return (rs, h, i, u, g, p', a) + return (rs, ls, h, i, u, g, p', a) | otherwise = do warning "The 'program-locations' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a) + parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "program-default-options" name fs) | name == "" = do a' <- parseFields withProgramOptionsFields a fs - return (rs, h, i, u, g, p, a') + return (rs, ls, h, i, u, g, p, a') | otherwise = do warning "The 'program-default-options' section should be unnamed" return accum @@ -1210,6 +1252,34 @@ warning $ "Unrecognized stanza on line " ++ show (lineNo f) return accum +postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo) +postProcessRepo lineno reponame repo0 = do + when (null reponame) $ + syntaxError lineno $ "a 'repository' section requires the " + ++ "repository name as an argument" + + case uriScheme (remoteRepoURI repo0) of + -- TODO: check that there are no authority, query or fragment + -- Note: the trailing colon is important + "file+noindex:" -> do + let uri = remoteRepoURI repo0 + return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache") + + _ -> do + let repo = repo0 { remoteRepoName = reponame } + + when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $ + warning $ "'key-threshold' for repository " + ++ show (remoteRepoName repo) + ++ " higher than number of keys" + + when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $ + warning $ "'root-keys' for repository " + ++ show (remoteRepoName repo) + ++ " non-empty, but 'secure' not set to True." + + return $ Right repo + showConfig :: SavedConfig -> String showConfig = showConfigWithComments mempty @@ -1220,8 +1290,9 @@ [] -> Disp.text "" (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs $+$ Disp.text "" - $+$ ppFields (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) - mcomment vals + $+$ ppFields + (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown)) + mcomment vals $+$ Disp.text "" $+$ ppSection "haddock" "" haddockFlagsFields (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals) @@ -1259,23 +1330,23 @@ ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals) - remoteRepoFields (Just def) vals + remoteRepoFields (Just def) vals remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields = - [ simpleField "url" - (text . show) (parseTokenQ >>= parseURI') - remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) - , simpleField "secure" - showSecure (Just `fmap` Text.parse) - remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) - , listField "root-keys" - text parseTokenQ - remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) - , simpleField "key-threshold" - showThreshold Text.parse - remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) - ] + [ simpleField "url" + (text . show) (parseTokenQ >>= parseURI') + remoteRepoURI (\x repo -> repo { remoteRepoURI = x }) + , simpleField "secure" + showSecure (Just `fmap` Text.parse) + remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x }) + , listField "root-keys" + text parseTokenQ + remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x }) + , simpleField "key-threshold" + showThreshold Text.parse + remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x }) + ] where parseURI' uriString = case parseURI uriString of @@ -1312,12 +1383,13 @@ , name `notElem` exclusions ] where exclusions = - ["author", "email", "quiet", "no-comments", "minimal", "overwrite", - "package-dir", "packagedir", "package-name", "version", "homepage", - "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe", - "simple", "main-is", "expose-module", "exposed-modules", "extension", - "dependency", "build-tool", "with-compiler", - "verbose"] + [ "author", "email", "quiet", "no-comments", "minimal", "overwrite" + , "package-dir", "packagedir", "package-name", "version", "homepage" + , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe" + , "simple", "main-is", "expose-module", "exposed-modules", "extension" + , "dependency", "build-tool", "with-compiler" + , "verbose" + ] -- | Fields for the 'program-locations' section. withProgramsFields :: [FieldDescr [(String, FilePath)]] @@ -1334,16 +1406,17 @@ 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) + 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. @@ -1352,10 +1425,11 @@ 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 `mappend` extraConfig)) + return $ + reverse . foldl' createDiff [] . M.toList + $ M.unionWith combine + (M.fromList . map justFst $ filterShow testConfig) + (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) where justFst (a, b) = (a, (Just b, Nothing)) justSnd (a, b) = (a, (Nothing, Just b)) @@ -1404,4 +1478,5 @@ notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." renameFile cabalFile backup notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." - writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig `mappend` extraConfig) + 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 @@ -24,6 +24,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic (safeHead) import Distribution.Client.Dependency import qualified Distribution.Client.InstallPlan as InstallPlan @@ -85,6 +86,8 @@ import Distribution.Verbosity as Verbosity ( Verbosity ) +import Data.Foldable + ( forM_ ) import System.FilePath ( () ) -- | Choose the Cabal version such that the setup scripts compiled against this @@ -272,12 +275,12 @@ -> ConfigExFlags -> IO () checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do - unless (null unknownConstraints) $ warn verbosity $ - "Constraint refers to an unknown package: " - ++ showConstraint (head unknownConstraints) - unless (null unknownPreferences) $ warn verbosity $ - "Preference refers to an unknown package: " - ++ display (head unknownPreferences) + forM_ (safeHead unknownConstraints) $ \h -> + warn verbosity $ "Constraint refers to an unknown package: " + ++ showConstraint h + forM_ (safeHead unknownPreferences) $ \h -> + warn verbosity $ "Preference refers to an unknown package: " + ++ display h where unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ configExConstraints flags diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -47,6 +47,7 @@ setPreferenceDefault, setReorderGoals, setCountConflicts, + setFineGrainedConflicts, setMinimizeConflictSet, setIndependentGoals, setAvoidReinstalls, @@ -159,6 +160,7 @@ depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, depResolverReorderGoals :: ReorderGoals, depResolverCountConflicts :: CountConflicts, + depResolverFineGrainedConflicts :: FineGrainedConflicts, depResolverMinimizeConflictSet :: MinimizeConflictSet, depResolverIndependentGoals :: IndependentGoals, depResolverAvoidReinstalls :: AvoidReinstalls, @@ -197,6 +199,7 @@ ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) ++ "\nreorder goals: " ++ show (asBool (depResolverReorderGoals p)) ++ "\ncount conflicts: " ++ show (asBool (depResolverCountConflicts p)) + ++ "\nfine grained conflicts: " ++ show (asBool (depResolverFineGrainedConflicts p)) ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p)) ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p)) ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) @@ -254,6 +257,7 @@ depResolverSourcePkgIndex = sourcePkgIndex, depResolverReorderGoals = ReorderGoals False, depResolverCountConflicts = CountConflicts True, + depResolverFineGrainedConflicts = FineGrainedConflicts True, depResolverMinimizeConflictSet = MinimizeConflictSet False, depResolverIndependentGoals = IndependentGoals False, depResolverAvoidReinstalls = AvoidReinstalls False, @@ -310,6 +314,12 @@ depResolverCountConflicts = count } +setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams +setFineGrainedConflicts fineGrained params = + params { + depResolverFineGrainedConflicts = fineGrained + } + setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams setMinimizeConflictSet minimize params = params { @@ -755,7 +765,8 @@ Step (showDepResolverParams finalparams) $ fmap (validateSolverResult platform comp indGoals) - $ runSolver solver (SolverConfig reordGoals cntConflicts minimize indGoals noReinstalls + $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize + indGoals noReinstalls shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj solveExes order verbosity (PruneAfterFirstSuccess False)) platform comp installedPkgIndex sourcePkgIndex @@ -769,6 +780,7 @@ sourcePkgIndex reordGoals cntConflicts + fineGrained minimize indGoals noReinstalls @@ -1015,9 +1027,9 @@ -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints prefs defpref installedPkgIndex sourcePkgIndex - _reorderGoals _countConflicts _minimizeConflictSet - _indGoals _avoidReinstalls _shadowing _strFlags - _maxBjumps _enableBj _solveExes + _reorderGoals _countConflicts _fineGrained + _minimizeConflictSet _indGoals _avoidReinstalls + _shadowing _strFlags _maxBjumps _enableBj _solveExes _allowBootLibInstalls _onlyConstrained _order _verbosity) = collectEithers $ map selectPackage (Set.toList targets) where diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs --- a/Distribution/Client/Dependency/Types.hs +++ b/Distribution/Client/Dependency/Types.hs @@ -2,23 +2,16 @@ module Distribution.Client.Dependency.Types ( PreSolver(..), Solver(..), - PackagesPreferenceDefault(..), - ) where -import Data.Char - ( isAlpha, toLower ) +import Distribution.Client.Compat.Prelude +import Prelude () -import qualified Distribution.Deprecated.ReadP as Parse - ( pfail, munch1 ) -import Distribution.Deprecated.Text - ( Text(..) ) +import Distribution.Deprecated.Text (Text (..)) +import Text.PrettyPrint (text) -import Text.PrettyPrint - ( text ) -import GHC.Generics (Generic) -import Distribution.Compat.Binary (Binary(..)) +import qualified Distribution.Deprecated.ReadP as Parse (munch1, pfail) -- | All the solvers that can be selected. @@ -31,6 +24,9 @@ instance Binary PreSolver instance Binary Solver + +instance Structured PreSolver +instance Structured Solver instance Text PreSolver where disp AlwaysModular = text "modular" diff --git a/Distribution/Client/DistDirLayout.hs b/Distribution/Client/DistDirLayout.hs --- a/Distribution/Client/DistDirLayout.hs +++ b/Distribution/Client/DistDirLayout.hs @@ -155,11 +155,11 @@ -- | Information about the root directory of the project. -- --- It can either be an implict project root in the current dir if no +-- It can either be an implicit project root in the current dir if no -- @cabal.project@ file is found, or an explicit root if the file is found. -- data ProjectRoot = - -- | -- ^ An implict project root. It contains the absolute project + -- | -- ^ An implicit project root. It contains the absolute project -- root dir. ProjectRootImplicit FilePath diff --git a/Distribution/Client/Exec.hs b/Distribution/Client/Exec.hs --- a/Distribution/Client/Exec.hs +++ b/Distribution/Client/Exec.hs @@ -89,7 +89,7 @@ Windows -> "PATH" _ -> "LD_LIBRARY_PATH" env getGlobalPackageDB hcProgram packagePathEnvVar = do - let Just program = lookupProgram hcProgram programDb + let program = fromMaybe (error "failed to find hcProgram") $ lookupProgram hcProgram programDb gDb <- getGlobalPackageDB verbosity program sandboxConfigFilePath <- getSandboxConfigFilePath mempty let sandboxPackagePath = sandboxPackageDBPath sandboxDir comp platform diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -162,6 +162,8 @@ . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts + . setMinimizeConflictSet minimizeConflictSet . setShadowPkgs shadowPkgs @@ -199,6 +201,7 @@ reorderGoals = fromFlag (fetchReorderGoals fetchFlags) countConflicts = fromFlag (fetchCountConflicts fetchFlags) + fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) independentGoals = fromFlag (fetchIndependentGoals fetchFlags) shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs --- a/Distribution/Client/FetchUtils.hs +++ b/Distribution/Client/FetchUtils.hs @@ -162,7 +162,7 @@ -- | Fetch a repo package if we don't have it already. -- fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath -fetchRepoTarball verbosity repoCtxt repo pkgid = do +fetchRepoTarball verbosity' repoCtxt repo pkgid = do fetched <- doesFileExist (packageFile repo pkgid) if fetched then do info verbosity $ display pkgid ++ " has already been downloaded." @@ -171,11 +171,13 @@ res <- downloadRepoPackage progressMessage verbosity ProgressDownloaded (display pkgid) return res - - where + -- whether we download or not is non-deterministic + verbosity = verboseUnmarkOutput verbosity' + downloadRepoPackage = case repo of RepoLocal{..} -> return (packageFile repo pkgid) + RepoLocalNoIndex{..} -> return (packageFile repo pkgid) RepoRemote{..} -> do transport <- repoContextGetTransport repoCtxt @@ -291,6 +293,7 @@ -- the tarball for a given @PackageIdentifer@ is stored. -- packageDir :: Repo -> PackageId -> FilePath +packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir packageDir repo pkgid = repoLocalDir repo display (packageName pkgid) display (packageVersion pkgid) diff --git a/Distribution/Client/FileMonitor.hs b/Distribution/Client/FileMonitor.hs --- a/Distribution/Client/FileMonitor.hs +++ b/Distribution/Client/FileMonitor.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving, NamedFieldPuns, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -34,6 +35,11 @@ updateFileMonitor, MonitorTimestamp, beginUpdateFileMonitor, + + -- * Internal + MonitorStateFileSet, + MonitorStateFile, + MonitorStateGlob, ) where import Prelude () @@ -41,7 +47,6 @@ import qualified Data.Map.Strict as Map import qualified Data.ByteString.Lazy as BS -import qualified Distribution.Compat.Binary as Binary import qualified Data.Hashable as Hashable import Control.Monad @@ -56,7 +61,7 @@ import Distribution.Client.Glob import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) import Distribution.Client.Utils (mergeBy, MergeResult(..)) - +import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) import System.FilePath import System.Directory import System.IO @@ -99,6 +104,10 @@ instance Binary MonitorKindFile instance Binary MonitorKindDir +instance Structured MonitorFilePath +instance Structured MonitorKindFile +instance Structured MonitorKindDir + -- | Monitor a single file for changes, based on its modification time. -- The monitored file is considered to have changed if it no longer -- exists or if its modification time has changed. @@ -202,8 +211,11 @@ -- there is also no particular gain either. That said, we do preserve the -- order of the lists just to reduce confusion (and have predictable I/O -- patterns). - deriving Show + deriving (Show, Generic) +instance Binary MonitorStateFileSet +instance Structured MonitorStateFileSet + type Hash = Int -- | The state necessary to determine whether a monitored file has changed. @@ -232,6 +244,8 @@ instance Binary MonitorStateFile instance Binary MonitorStateFileStatus +instance Structured MonitorStateFile +instance Structured MonitorStateFileStatus -- | The state necessary to determine whether the files matched by a globbing -- match have changed. @@ -257,6 +271,9 @@ instance Binary MonitorStateGlob instance Binary MonitorStateGlobRel +instance Structured MonitorStateGlob +instance Structured MonitorStateGlobRel + -- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by -- inspecting the state of the file system, and we can go in the reverse -- direction by just forgetting the extra info. @@ -399,7 +416,7 @@ -- See 'FileMonitor' for a full explanation. -- checkFileMonitorChanged - :: (Binary a, Binary b) + :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -- ^ cache file path -> FilePath -- ^ root directory -> a -- ^ guard or key value @@ -477,23 +494,24 @@ -- -- This determines the type and format of the binary cache file. -- -readCacheFile :: (Binary a, Binary b) +readCacheFile :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -> IO (Either String (MonitorStateFileSet, a, b)) readCacheFile FileMonitor {fileMonitorCacheFile} = - withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> - Binary.decodeOrFailIO =<< BS.hGetContents hnd + withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do + contents <- BS.hGetContents hnd + structuredDecodeOrFailIO contents -- | Helper for writing the cache file. -- -- This determines the type and format of the binary cache file. -- -rewriteCacheFile :: (Binary a, Binary b) +rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -> MonitorStateFileSet -> a -> b -> IO () rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = writeFileAtomic fileMonitorCacheFile $ - Binary.encode (fileset, key, result) + structuredEncode (fileset, key, result) -- | Probe the file system to see if any of the monitored files have changed. -- @@ -754,7 +772,7 @@ -- any files then you can use @Nothing@ for the timestamp parameter. -- updateFileMonitor - :: (Binary a, Binary b) + :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -- ^ cache file path -> FilePath -- ^ root directory -> Maybe MonitorTimestamp -- ^ timestamp when the update action started @@ -961,7 +979,7 @@ -- that the set of files to monitor can change then it's simpler just to throw -- away the structure and use a finite map. -- -readCacheFileHashes :: (Binary a, Binary b) +readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -> IO FileHashCache readCacheFileHashes monitor = handleDoesNotExist Map.empty $ @@ -1080,12 +1098,17 @@ then return Nothing else return (Just mtime') --- | Run an IO computation, returning @e@ if there is an 'error' +-- | Run an IO computation, returning the first argument @e@ if there is an 'error' -- call. ('ErrorCall') handleErrorCall :: a -> IO a -> IO a -handleErrorCall e = - handle (\(ErrorCall _) -> return e) +handleErrorCall e = handle handler where +#if MIN_VERSION_base(4,9,0) + handler (ErrorCallWithLocation _ _) = return e +#else + handler (ErrorCall _) = return e +#endif + -- | Run an IO computation, returning @e@ if there is any 'IOException'. -- -- This policy is OK in the file monitor code because it just causes the @@ -1105,15 +1128,3 @@ -- Instances -- -instance Binary MonitorStateFileSet where - put (MonitorStateFileSet singlePaths globPaths) = do - put (1 :: Int) -- version - put singlePaths - put globPaths - get = do - ver <- get - if ver == (1 :: Int) - then do singlePaths <- get - globPaths <- get - return $! MonitorStateFileSet singlePaths globPaths - else fail "MonitorStateFileSet: wrong version" diff --git a/Distribution/Client/Freeze.hs b/Distribution/Client/Freeze.hs --- a/Distribution/Client/Freeze.hs +++ b/Distribution/Client/Freeze.hs @@ -175,6 +175,8 @@ . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts + . setMinimizeConflictSet minimizeConflictSet . setShadowPkgs shadowPkgs @@ -207,6 +209,7 @@ reorderGoals = fromFlag (freezeReorderGoals freezeFlags) countConflicts = fromFlag (freezeCountConflicts freezeFlags) + fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) independentGoals = fromFlag (freezeIndependentGoals freezeFlags) shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) diff --git a/Distribution/Client/GZipUtils.hs b/Distribution/Client/GZipUtils.hs --- a/Distribution/Client/GZipUtils.hs +++ b/Distribution/Client/GZipUtils.hs @@ -18,12 +18,14 @@ maybeDecompress, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Codec.Compression.Zlib.Internal import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) #if MIN_VERSION_zlib(0,6,0) import Control.Exception (throw) -import Control.Monad (liftM) import Control.Monad.ST.Lazy (ST, runST) import qualified Data.ByteString as Strict #endif diff --git a/Distribution/Client/GenBounds.hs b/Distribution/Client/GenBounds.hs --- a/Distribution/Client/GenBounds.hs +++ b/Distribution/Client/GenBounds.hs @@ -17,6 +17,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic (safeLast) import Distribution.Client.Init ( incVersion ) @@ -59,9 +60,9 @@ -- | Does this version range have an upper bound? hasUpperBound :: VersionRange -> Bool hasUpperBound vr = - case asVersionIntervals vr of - [] -> False - is -> if snd (last is) == NoUpperBound then False else True + case safeLast (asVersionIntervals vr) of + Nothing -> False + Just l -> if snd l == NoUpperBound then False else True -- | Given a version, return an API-compatible (according to PVP) version range. -- diff --git a/Distribution/Client/Get.hs b/Distribution/Client/Get.hs --- a/Distribution/Client/Get.hs +++ b/Distribution/Client/Get.hs @@ -24,6 +24,7 @@ import Prelude () import Distribution.Client.Compat.Prelude hiding (get) +import Data.Ord (comparing) import Distribution.Compat.Directory ( listDirectory ) import Distribution.Package @@ -34,10 +35,13 @@ ( notice, die', info, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) +import Distribution.Pretty (prettyShow) import Distribution.Deprecated.Text (display) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program ( programName ) +import Distribution.Types.SourceRepo (RepoKind (..)) +import Distribution.Client.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy) import Distribution.Client.Setup ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) @@ -114,7 +118,7 @@ . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) where kind = fromFlag . getSourceRepository $ getFlags - packageSourceRepos :: SourcePackage loc -> [SourceRepo] + packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo] packageSourceRepos = PD.sourceRepos . PD.packageDescription . packageDescription @@ -197,11 +201,11 @@ data ClonePackageException = ClonePackageNoSourceRepos PackageId | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) - | ClonePackageNoRepoType PackageId SourceRepo - | ClonePackageUnsupportedRepoType PackageId SourceRepo RepoType - | ClonePackageNoRepoLocation PackageId SourceRepo + | ClonePackageNoRepoType PackageId PD.SourceRepo + | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType + | ClonePackageNoRepoLocation PackageId PD.SourceRepo | ClonePackageDestinationExists PackageId FilePath Bool - | ClonePackageFailedWithExitCode PackageId SourceRepo String ExitCode + | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode deriving (Show, Eq) instance Exception ClonePackageException where @@ -237,7 +241,7 @@ displayException (ClonePackageFailedWithExitCode pkgid repo vcsprogname exitcode) = "Failed to fetch the source repository for package " ++ display pkgid - ++ maybe "" (", repository location " ++) (PD.repoLocation repo) ++ " (" + ++ ", repository location " ++ srpLocation repo ++ " (" ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." @@ -248,7 +252,7 @@ clonePackagesFromSourceRepo :: Verbosity -> FilePath -- ^ destination dir prefix -> Maybe RepoKind -- ^ preferred 'RepoKind' - -> [(PackageId, [SourceRepo])] + -> [(PackageId, [PD.SourceRepo])] -- ^ the packages and their -- available 'SourceRepo's -> IO () @@ -268,14 +272,14 @@ [ cloneSourceRepo verbosity vcs' repo destDir `catch` \exitcode -> throwIO (ClonePackageFailedWithExitCode - pkgid repo (programName (vcsProgram vcs)) exitcode) + pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode) | (pkgid, repo, vcs, destDir) <- pkgrepos' - , let Just vcs' = Map.lookup (vcsRepoType vcs) vcss + , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss ] where - preCloneChecks :: (PackageId, [SourceRepo]) - -> IO (PackageId, SourceRepo, VCS Program, FilePath) + preCloneChecks :: (PackageId, [PD.SourceRepo]) + -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) preCloneChecks (pkgid, repos) = do repo <- case selectPackageSourceRepo preferredRepoKind repos of Just repo -> return repo @@ -283,13 +287,13 @@ Nothing -> throwIO (ClonePackageNoSourceReposOfKind pkgid preferredRepoKind) - vcs <- case validateSourceRepo repo of - Right (_, _, _, vcs) -> return vcs + (repo', vcs) <- case validatePDSourceRepo repo of + Right (repo', _, _, vcs) -> return (repo', vcs) Left SourceRepoRepoTypeUnspecified -> throwIO (ClonePackageNoRepoType pkgid repo) - Left (SourceRepoRepoTypeUnsupported repoType) -> - throwIO (ClonePackageUnsupportedRepoType pkgid repo repoType) + Left (SourceRepoRepoTypeUnsupported repo' repoType) -> + throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType) Left SourceRepoLocationUnspecified -> throwIO (ClonePackageNoRepoLocation pkgid repo) @@ -300,5 +304,37 @@ when (destDirExists || destFileExists) $ throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) - return (pkgid, repo, vcs, destDir) + return (pkgid, repo', vcs, destDir) +------------------------------------------------------------------------------- +-- Selecting +------------------------------------------------------------------------------- + +-- | Pick the 'SourceRepo' to use to get the package sources from. +-- +-- Note that this does /not/ depend on what 'VCS' drivers we are able to +-- successfully configure. It is based only on the 'SourceRepo's declared +-- in the package, and optionally on a preferred 'RepoKind'. +-- +selectPackageSourceRepo :: Maybe RepoKind + -> [PD.SourceRepo] + -> Maybe PD.SourceRepo +selectPackageSourceRepo preferredRepoKind = + listToMaybe + -- Sort repositories by kind, from This to Head to Unknown. Repositories + -- with equivalent kinds are selected based on the order they appear in + -- the Cabal description file. + . sortBy (comparing thisFirst) + -- If the user has specified the repo kind, filter out the repositories + -- they're not interested in. + . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind) + where + thisFirst :: PD.SourceRepo -> Int + thisFirst r = case PD.repoKind r of + RepoThis -> 0 + RepoHead -> case PD.repoTag r of + -- If the type is 'head' but the author specified a tag, they + -- probably meant to create a 'this' repository but screwed up. + Just _ -> 0 + Nothing -> 1 + RepoKindUnknown _ -> 2 diff --git a/Distribution/Client/Glob.hs b/Distribution/Client/Glob.hs --- a/Distribution/Client/Glob.hs +++ b/Distribution/Client/Glob.hs @@ -61,6 +61,10 @@ instance Binary FilePathGlobRel instance Binary GlobPiece +instance Structured FilePathGlob +instance Structured FilePathRoot +instance Structured FilePathGlobRel +instance Structured GlobPiece -- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and -- is in fact equivalent to a non-glob 'FilePath'. diff --git a/Distribution/Client/GlobalFlags.hs b/Distribution/Client/GlobalFlags.hs --- a/Distribution/Client/GlobalFlags.hs +++ b/Distribution/Client/GlobalFlags.hs @@ -17,7 +17,7 @@ import Distribution.Client.Compat.Prelude import Distribution.Client.Types - ( Repo(..), RemoteRepo(..) ) + ( Repo(..), RemoteRepo(..), LocalRepo (..), localRepoCacheKey ) import Distribution.Simple.Setup ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList @@ -27,7 +27,7 @@ import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils - ( info ) + ( info, warn ) import Control.Concurrent ( MVar, newMVar, modifyMVar ) @@ -48,6 +48,8 @@ import qualified Distribution.Client.Security.HTTP as Sec.HTTP import qualified Distribution.Client.Security.DNS as Sec.DNS +import qualified System.FilePath.Posix as FilePath.Posix + -- ------------------------------------------------------------ -- * Global flags -- ------------------------------------------------------------ @@ -62,6 +64,7 @@ globalRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. globalCacheDir :: Flag FilePath, globalLocalRepos :: NubList FilePath, + globalLocalNoIndexRepos :: NubList LocalRepo, globalLogsDir :: Flag FilePath, globalWorldFile :: Flag FilePath, globalRequireSandbox :: Flag Bool, @@ -83,6 +86,7 @@ globalRemoteRepos = mempty, globalCacheDir = mempty, globalLocalRepos = mempty, + globalLocalNoIndexRepos = mempty, globalLogsDir = mempty, globalWorldFile = mempty, globalRequireSandbox = Flag False, @@ -141,20 +145,25 @@ withRepoContext verbosity globalFlags = withRepoContext' verbosity - (fromNubList (globalRemoteRepos globalFlags)) - (fromNubList (globalLocalRepos globalFlags)) - (fromFlag (globalCacheDir globalFlags)) - (flagToMaybe (globalHttpTransport globalFlags)) - (flagToMaybe (globalIgnoreExpiry globalFlags)) - (fromNubList (globalProgPathExtra globalFlags)) + (fromNubList (globalRemoteRepos globalFlags)) + (fromNubList (globalLocalRepos globalFlags)) + (fromNubList (globalLocalNoIndexRepos globalFlags)) + (fromFlag (globalCacheDir globalFlags)) + (flagToMaybe (globalHttpTransport globalFlags)) + (flagToMaybe (globalIgnoreExpiry globalFlags)) + (fromNubList (globalProgPathExtra globalFlags)) -withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] +withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] -> [LocalRepo] -> FilePath -> Maybe String -> Maybe Bool -> [FilePath] -> (RepoContext -> IO a) -> IO a -withRepoContext' verbosity remoteRepos localRepos +withRepoContext' verbosity remoteRepos localRepos localNoIndexRepos sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do + for_ localNoIndexRepos $ \local -> + unless (FilePath.Posix.isAbsolute (localRepoPath local)) $ + warn verbosity $ "file+noindex " ++ localRepoName local ++ " repository path is not absolute; this is fragile, and not recommended" + transportRef <- newMVar Nothing let httpLib = Sec.HTTP.transportAdapter verbosity @@ -162,6 +171,7 @@ initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' -> callback RepoContext { repoContextRepos = allRemoteRepos + ++ allLocalNoIndexRepos ++ map RepoLocal localRepos , repoContextGetTransport = getTransport transportRef , repoContextWithSecureRepo = withSecureRepo secureRepos' @@ -170,11 +180,21 @@ where secureRemoteRepos = [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ] + + allRemoteRepos :: [Repo] allRemoteRepos = [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir | remote <- remoteRepos , let cacheDir = sharedCacheDir remoteRepoName remote isSecure = remoteRepoSecure remote == Just True + ] + + allLocalNoIndexRepos :: [Repo] + allLocalNoIndexRepos = + [ RepoLocalNoIndex local cacheDir + | local <- localNoIndexRepos + , let cacheDir | localRepoSharedCache local = sharedCacheDir localRepoCacheKey local + | otherwise = localRepoPath local ] getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport diff --git a/Distribution/Client/HashValue.hs b/Distribution/Client/HashValue.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/HashValue.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Client.HashValue ( + HashValue, + hashValue, + truncateHash, + showHashValue, + readFileHashValue, + hashFromTUF, + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import qualified Hackage.Security.Client as Sec + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Control.Exception (evaluate) +import System.IO (IOMode (..), withBinaryFile) + +----------------------------------------------- +-- The specific choice of hash implementation +-- + +-- Is a crypto hash necessary here? One thing to consider is who controls the +-- inputs and what's the result of a hash collision. Obviously we should not +-- install packages we don't trust because they can run all sorts of code, but +-- if I've checked there's no TH, no custom Setup etc, is there still a +-- problem? If someone provided us a tarball that hashed to the same value as +-- some other package and we installed it, we could end up re-using that +-- installed package in place of another one we wanted. So yes, in general +-- there is some value in preventing intentional hash collisions in installed +-- package ids. + +newtype HashValue = HashValue BS.ByteString + deriving (Eq, Generic, Show, Typeable) + +-- Cannot do any sensible validation here. Although we use SHA256 +-- for stuff we hash ourselves, we can also get hashes from TUF +-- and that can in principle use different hash functions in future. +-- +-- Therefore, we simply derive this structurally. +instance Binary HashValue +instance Structured HashValue + +-- | Hash some data. Currently uses SHA256. +-- +hashValue :: LBS.ByteString -> HashValue +hashValue = HashValue . SHA256.hashlazy + +showHashValue :: HashValue -> String +showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) + +-- | Hash the content of a file. Uses SHA256. +-- +readFileHashValue :: FilePath -> IO HashValue +readFileHashValue tarball = + withBinaryFile tarball ReadMode $ \hnd -> + evaluate . hashValue =<< LBS.hGetContents hnd + +-- | Convert a hash from TUF metadata into a 'PackageSourceHash'. +-- +-- Note that TUF hashes don't neessarily have to be SHA256, since it can +-- support new algorithms in future. +-- +hashFromTUF :: Sec.Hash -> HashValue +hashFromTUF (Sec.Hash hashstr) = + --TODO: [code cleanup] either we should get TUF to use raw bytestrings or + -- perhaps we should also just use a base16 string as the internal rep. + case Base16.decode (BS.pack hashstr) of + (hash, trailing) | not (BS.null hash) && BS.null trailing + -> HashValue hash + _ -> error "hashFromTUF: cannot decode base16 hash" + + +-- | Truncate a 32 byte SHA256 hash to +-- +-- For example 20 bytes render as 40 hex chars, which we use for unit-ids. +-- Or even 4 bytes for 'hashedInstalledPackageIdShort' +-- +truncateHash :: Int -> HashValue -> HashValue +truncateHash n (HashValue h) = HashValue (BS.take n h) diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -15,7 +15,8 @@ ) where import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Client.Compat.Prelude hiding (Proxy (..)) +import Distribution.Utils.Generic import Network.HTTP ( Request (..), Response (..), RequestMethod (..) @@ -38,8 +39,8 @@ import Distribution.Verbosity (Verbosity) import Distribution.Pretty (prettyShow) import Distribution.Simple.Utils - ( die', info, warn, debug, notice, writeFileAtomic - , copyFileVerbose, withTempFile ) + ( die', info, warn, debug, notice + , copyFileVerbose, withTempFile, IOData (..) ) import Distribution.Client.Utils ( withTempFileName ) import Distribution.Client.Types @@ -281,7 +282,7 @@ Just prog -> snd <$> requireProgram verbosity prog baseProgDb -- ^^ if it fails, it'll fail here - let Just transport = mkTrans progdb + let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb return transport { transportManuallySelected = True } Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name @@ -305,8 +306,8 @@ [ (name, transport) | (name, _, _, mkTrans) <- supportedTransports , transport <- maybeToList (mkTrans progdb) ] - -- there's always one because the plain one is last and never fails - let (name, transport) = head availableTransports + let (name, transport) = + fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports) debug verbosity $ "Selected http transport implementation: " ++ name return transport { transportManuallySelected = False } @@ -350,7 +351,7 @@ addAuthConfig auth progInvocation = progInvocation { progInvokeInput = do (uname, passwd) <- auth - return $ unlines + return $ IODataText $ unlines [ "--digest" , "--user " ++ uname ++ ":" ++ passwd ] @@ -507,7 +508,7 @@ -- and sensitive data should not be passed via command line arguments. let invocation = (programInvocation prog ("--input-file=-" : args)) - { progInvokeInput = Just (uriToString id uri "") + { progInvokeInput = Just $ IODataText $ uriToString id uri "" } -- wget returns its output on stderr rather than stdout @@ -618,7 +619,7 @@ ] debug verbosity script getProgramInvocationOutput verbosity (programInvocation prog args) - { progInvokeInput = Just (script ++ "\nExit(0);") + { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);" } escape = show @@ -644,9 +645,11 @@ HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value HdrReferer -> "Referer = " ++ escape value HdrTransferEncoding -> "TransferEncoding = " ++ escape value - HdrRange -> let (start, _:end) = + HdrRange -> let (start, end) = if "bytes=" `isPrefixOf` value - then break (== '-') value' + then case break (== '-') value' of + (start', '-':end') -> (start', end') + _ -> error $ "Could not decode range: " ++ value else error $ "Could not decode range: " ++ value value' = drop 6 value in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");" diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- @@ -50,6 +51,8 @@ import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types import Distribution.Verbosity +import Distribution.Pretty (prettyShow) +import Distribution.Parsec (simpleParsec) import Distribution.Package ( PackageId, PackageIdentifier(..), mkPackageName @@ -70,7 +73,7 @@ import Distribution.Deprecated.Text ( display, simpleParse ) import Distribution.Simple.Utils - ( die', warn, info ) + ( die', warn, info, createDirectoryIfMissingVerbose ) import Distribution.Client.Setup ( RepoContext(..) ) @@ -83,9 +86,11 @@ import Distribution.Solver.Types.SourcePackage import qualified Data.Map as Map +import qualified Data.Set as Set import Control.DeepSeq import Control.Monad import Control.Exception +import Data.List (stripPrefix) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS @@ -93,18 +98,20 @@ import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath , tryFindAddSourcePackageDesc ) -import Distribution.Compat.Binary +import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail) import Distribution.Compat.Exception (catchIO) import Distribution.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist, doesDirectoryExist) import System.FilePath - ( (), (<.>), takeExtension, replaceExtension, splitDirectories, normalise ) -import System.FilePath.Posix as FilePath.Posix - ( takeFileName ) + ( (), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory ) +import qualified System.FilePath.Posix as FilePath.Posix import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) +import Distribution.Compat.Directory (listDirectory) +import qualified Codec.Compression.GZip as GZip + import qualified Hackage.Security.Client as Sec import qualified Hackage.Security.Util.Some as Sec @@ -130,9 +137,10 @@ indexBaseName repo = repoLocalDir repo fn where fn = case repo of - RepoSecure {} -> "01-index" - RepoRemote {} -> "00-index" - RepoLocal {} -> "00-index" + RepoSecure {} -> "01-index" + RepoRemote {} -> "00-index" + RepoLocal {} -> "00-index" + RepoLocalNoIndex {} -> "noindex" ------------------------------------------------------------------------ -- Reading the source package index @@ -218,7 +226,12 @@ describeState (IndexStateTime time) = "historical state as of " ++ display time pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do - let rname = maybe "" remoteRepoName $ maybeRepoRemote r + let rname = case r of + RepoRemote remote _ -> remoteRepoName remote + RepoSecure remote _ -> remoteRepoName remote + RepoLocalNoIndex local _ -> localRepoName local + RepoLocal _ -> "" + info verbosity ("Reading available packages of " ++ rname ++ "...") idxState <- case mb_idxState of @@ -240,6 +253,7 @@ unless (idxState == IndexStateHead) $ case r of RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')") + RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories" RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')") RepoSecure {} -> pure () @@ -301,7 +315,7 @@ -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) readRepoIndex verbosity repoCtxt repo idxState = handleNotFound $ do - warnIfIndexIsOld =<< getIndexFileAge repo + when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) readPackageIndexCacheFile verbosity mkAvailablePackage (RepoIndex repoCtxt repo) @@ -330,6 +344,10 @@ RepoLocal{..} -> warn verbosity $ "The package list for the local repo '" ++ repoLocalDir ++ "' is missing. The repo is invalid." + RepoLocalNoIndex local _ -> warn verbosity $ + "Error during construction of local+noindex " + ++ localRepoName local ++ " repository index: " + ++ show e return (mempty,mempty,emptyStateInfo) else ioError e @@ -338,11 +356,12 @@ when (dt >= isOldThreshold) $ case repo of RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt - RepoLocal{..} -> return () + RepoLocal{} -> return () + RepoLocalNoIndex {} -> return () errMissingPackageList repoRemote = "The package list for '" ++ remoteRepoName repoRemote - ++ "' does not exist. Run 'cabal update' to download it." + ++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote errOutdatedPackageList repoRemote dt = "The package list for '" ++ remoteRepoName repoRemote ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun " @@ -366,19 +385,24 @@ -- updateRepoIndexCache :: Verbosity -> Index -> IO () updateRepoIndexCache verbosity index = - whenCacheOutOfDate index $ do - updatePackageIndexCacheFile verbosity index + whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index whenCacheOutOfDate :: Index -> IO () -> IO () whenCacheOutOfDate index action = do exists <- doesFileExist $ cacheFile index if not exists - then action - else do - indexTime <- getModTime $ indexFile index - cacheTime <- getModTime $ cacheFile index - when (indexTime > cacheTime) action + then action + else if localNoIndex index + then return () -- TODO: don't update cache for local+noindex repositories + else do + indexTime <- getModTime $ indexFile index + cacheTime <- getModTime $ cacheFile index + when (indexTime > cacheTime) action +localNoIndex :: Index -> Bool +localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True +localNoIndex _ = False + ------------------------------------------------------------------------ -- Reading the index file -- @@ -391,9 +415,10 @@ -- | A build tree reference is either a link or a snapshot. data BuildTreeRefType = SnapshotRef | LinkRef - deriving (Eq,Generic) + deriving (Eq,Show,Generic) instance Binary BuildTreeRefType +instance Structured BuildTreeRefType refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType refTypeFromTypeCode t @@ -492,7 +517,7 @@ extractPrefs :: Tar.Entry -> Maybe [Dependency] extractPrefs entry = case Tar.entryContent entry of Tar.NormalFile content _ - | takeFileName entrypath == "preferred-versions" + | FilePath.Posix.takeFileName entrypath == "preferred-versions" -> Just prefs where entrypath = Tar.entryPath entry @@ -562,21 +587,28 @@ RepoSecure {} -> True RepoRemote {} -> False RepoLocal {} -> False + RepoLocalNoIndex {} -> True is01Index (SandboxIndex _) = False updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...") - withIndexEntries verbosity index $ \entries -> do - let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) - cache = Cache { cacheHeadTs = maxTs - , cacheEntries = entries - } - writeIndexCache index cache - info verbosity ("Index cache updated to index-state " - ++ display (cacheHeadTs cache)) + withIndexEntries verbosity index callback callbackNoIndex + where + callback entries = do + let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries) + cache = Cache { cacheHeadTs = maxTs + , cacheEntries = entries + } + writeIndexCache index cache + info verbosity ("Index cache updated to index-state " + ++ display (cacheHeadTs cache)) + callbackNoIndex entries = do + writeNoIndexCache verbosity index $ NoIndexCache entries + info verbosity "Index cache updated" + -- | Read the index (for the purpose of building a cache) -- -- The callback is provided with list of cache entries, which is guaranteed to @@ -597,8 +629,12 @@ -- TODO: It would be nicer if we actually incrementally updated @cabal@'s -- cache, rather than reconstruct it from zero on each update. However, this -- would require a change in the cache format. -withIndexEntries :: Verbosity -> Index -> ([IndexCacheEntry] -> IO a) -> IO a -withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback = +withIndexEntries + :: Verbosity -> Index + -> ([IndexCacheEntry] -> IO a) + -> ([NoIndexCacheEntry] -> IO a) + -> IO a +withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback _ = repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do -- Incrementally (lazily) read all the entries in the tar file in order, @@ -625,7 +661,60 @@ timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ epochTimeToTimestamp $ Sec.indexEntryTime sie -withIndexEntries verbosity index callback = do -- non-secure repositories +withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do + dirContents <- listDirectory localDir + let contentSet = Set.fromList dirContents + + entries <- handle handler $ fmap catMaybes $ forM dirContents $ \file -> do + case isTarGz file of + Nothing -> do + unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $ + info verbosity $ "Skipping " ++ file + return Nothing + Just pkgid | cabalPath `Set.member` contentSet -> do + contents <- BSS.readFile (localDir cabalPath) + forM (parseGenericPackageDescriptionMaybe contents) $ \gpd -> + return (CacheGPD gpd contents) + where + cabalPath = prettyShow pkgid ++ ".cabal" + Just pkgId -> do + -- check for the right named .cabal file in the compressed tarball + tarGz <- BS.readFile (localDir file) + let tar = GZip.decompress tarGz + entries = Tar.read tar + + case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of + Just ce -> return (Just ce) + Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file + + info verbosity $ "Entries in file+noindex repository " ++ name + for_ entries $ \(CacheGPD gpd _) -> + info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd) + + callback entries + where + handler :: IOException -> IO a + handler e = die' verbosity $ "Error while updating index for " ++ name ++ " repository " ++ show e + + isTarGz :: FilePath -> Maybe PackageIdentifier + isTarGz fp = do + pfx <- stripSuffix ".tar.gz" fp + simpleParsec pfx + + stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str)) + + -- look for /.cabal inside the tarball + readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry + readCabalEntry pkgId entry Nothing + | filename == Tar.entryPath entry + , Tar.NormalFile contents _ <- Tar.entryContent entry + = let bs = BS.toStrict contents + in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs + where + filename = prettyShow pkgId FilePath.Posix. prettyShow (packageName pkgId) ++ ".cabal" + readCabalEntry _ _ x = x + +withIndexEntries verbosity index callback _ = do -- non-secure repositories withFile (indexFile index) ReadMode $ \h -> do bs <- maybeDecompress `fmap` BS.hGetContents h pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs @@ -642,13 +731,18 @@ -> Index -> IndexState -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) -readPackageIndexCacheFile verbosity mkPkg index idxState = do - cache0 <- readIndexCache verbosity index - indexHnd <- openFile (indexFile index) ReadMode - let (cache,isi) = filterCache idxState cache0 - (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache - pure (pkgs,deps,isi) +readPackageIndexCacheFile verbosity mkPkg index idxState + | localNoIndex index = do + cache0 <- readNoIndexCache verbosity index + pkgs <- packageNoIndexFromCache verbosity mkPkg cache0 + pure (pkgs, [], emptyStateInfo) + | otherwise = do + cache0 <- readIndexCache verbosity index + indexHnd <- openFile (indexFile index) ReadMode + let (cache,isi) = filterCache idxState cache0 + (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache + pure (pkgs,deps,isi) packageIndexFromCache :: Package pkg => Verbosity @@ -661,6 +755,21 @@ pkgIndex <- evaluate $ PackageIndex.fromList pkgs return (pkgIndex, prefs) +packageNoIndexFromCache + :: forall pkg. Package pkg + => Verbosity + -> (PackageEntry -> pkg) + -> NoIndexCache + -> IO (PackageIndex pkg) +packageNoIndexFromCache _verbosity mkPkg cache = + evaluate $ PackageIndex.fromList pkgs + where + pkgs = + [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0 + | CacheGPD gpd bs <- noIndexCacheEntries cache + , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd + ] + -- | Read package list -- -- The result package releases and preference entries are guaranteed @@ -749,8 +858,7 @@ ------------------------------------------------------------------------ --- Index cache data structure --- +-- Index cache data structure -- -- | Read the 'Index' cache from the filesystem -- @@ -773,20 +881,46 @@ Right res -> return (hashConsCache res) +readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache +readNoIndexCache verbosity index = do + cacheOrFail <- readNoIndexCache' index + case cacheOrFail of + Left msg -> do + warn verbosity $ concat + [ "Parsing the index cache failed (", msg, "). " + , "Trying to regenerate the index cache..." + ] + + updatePackageIndexCacheFile verbosity index + + either (die' verbosity) return =<< readNoIndexCache' index + + -- we don't hash cons local repository cache, they are hopefully small + Right res -> return res + -- | Read the 'Index' cache from the filesystem without attempting to -- regenerate on parsing failures. readIndexCache' :: Index -> IO (Either String Cache) readIndexCache' index - | is01Index index = decodeFileOrFail' (cacheFile index) + | is01Index index = structuredDecodeFileOrFail (cacheFile index) | otherwise = liftM (Right .read00IndexCache) $ BSS.readFile (cacheFile index) +readNoIndexCache' :: Index -> IO (Either String NoIndexCache) +readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index) + -- | Write the 'Index' cache to the filesystem writeIndexCache :: Index -> Cache -> IO () writeIndexCache index cache - | is01Index index = encodeFile (cacheFile index) cache + | is01Index index = structuredEncodeFile (cacheFile index) cache | otherwise = writeFile (cacheFile index) (show00IndexCache cache) +writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO () +writeNoIndexCache verbosity index cache = do + let path = cacheFile index + createDirectoryIfMissingVerbose verbosity True (takeDirectory path) + structuredEncodeFile path cache + -- | Write the 'IndexState' to the filesystem writeIndexTimestamp :: Index -> IndexState -> IO () writeIndexTimestamp index st @@ -852,28 +986,44 @@ -- 'cacheEntries' , cacheEntries :: [IndexCacheEntry] } + deriving (Show, Generic) instance NFData Cache where rnf = rnf . cacheEntries +-- | Cache format for 'file+noindex' repositories +newtype NoIndexCache = NoIndexCache + { noIndexCacheEntries :: [NoIndexCacheEntry] + } + deriving (Show, Generic) + +instance NFData NoIndexCache where + rnf = rnf . noIndexCacheEntries + -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. -- type BlockNo = Word32 -- Tar.TarEntryOffset - data IndexCacheEntry = CachePackageId PackageId !BlockNo !Timestamp | CachePreference Dependency !BlockNo !Timestamp | CacheBuildTreeRef !BuildTreeRefType !BlockNo -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build - deriving (Eq,Generic) + deriving (Eq,Show,Generic) +data NoIndexCacheEntry + = CacheGPD GenericPackageDescription !BSS.ByteString + deriving (Eq,Show,Generic) + instance NFData IndexCacheEntry where rnf (CachePackageId pkgid _ _) = rnf pkgid rnf (CachePreference dep _ _) = rnf dep rnf (CacheBuildTreeRef _ _) = () +instance NFData NoIndexCacheEntry where + rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs + cacheEntryTimestamp :: IndexCacheEntry -> Timestamp cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp cacheEntryTimestamp (CachePreference _ _ ts) = ts @@ -882,24 +1032,26 @@ ---------------------------------------------------------------------------- -- new binary 01-index.cache format -instance Binary Cache where - put (Cache headTs ents) = do - -- magic / format version - -- - -- NB: this currently encodes word-size implicitly; when we - -- switch to CBOR encoding, we will have a platform - -- independent binary encoding - put (0xcaba1002::Word) - put headTs - put ents +instance Binary Cache +instance Binary IndexCacheEntry +instance Binary NoIndexCache +instance Structured Cache +instance Structured IndexCacheEntry +instance Structured NoIndexCache + +-- | We need to save only .cabal file contents +instance Binary NoIndexCacheEntry where + put (CacheGPD _ bs) = put bs + get = do - magic <- get - when (magic /= (0xcaba1002::Word)) $ - fail ("01-index.cache: unexpected magic marker encountered: " ++ show magic) - Cache <$> get <*> get + bs <- get + case parseGenericPackageDescriptionMaybe bs of + Just gpd -> return (CacheGPD gpd bs) + Nothing -> fail "Failed to parse GPD" -instance Binary IndexCacheEntry +instance Structured NoIndexCacheEntry where + structure = nominalStructure ---------------------------------------------------------------------------- -- legacy 00-index.cache format @@ -972,16 +1124,19 @@ show00IndexCacheEntry :: IndexCacheEntry -> String show00IndexCacheEntry entry = unwords $ case entry of - CachePackageId pkgid b _ -> [ packageKey - , display (packageName pkgid) - , display (packageVersion pkgid) - , blocknoKey - , show b - ] - CacheBuildTreeRef tr b -> [ buildTreeRefKey - , [typeCodeFromRefType tr] - , show b - ] - CachePreference dep _ _ -> [ preferredVersionKey - , display dep - ] + CachePackageId pkgid b _ -> + [ packageKey + , display (packageName pkgid) + , display (packageVersion pkgid) + , blocknoKey + , show b + ] + CacheBuildTreeRef tr b -> + [ buildTreeRefKey + , [typeCodeFromRefType tr] + , show b + ] + CachePreference dep _ _ -> + [ preferredVersionKey + , display dep + ] diff --git a/Distribution/Client/IndexUtils/Timestamp.hs b/Distribution/Client/IndexUtils/Timestamp.hs --- a/Distribution/Client/IndexUtils/Timestamp.hs +++ b/Distribution/Client/IndexUtils/Timestamp.hs @@ -21,21 +21,20 @@ , IndexState(..) ) where +import Distribution.Client.Compat.Prelude + +-- read is needed for Text instance +import Prelude (read) + import qualified Codec.Archive.Tar.Entry as Tar -import Control.DeepSeq -import Control.Monad -import Data.Char (isDigit) -import Data.Int (Int64) import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) -import Distribution.Compat.Binary import qualified Distribution.Deprecated.ReadP as ReadP import Distribution.Deprecated.Text import qualified Text.PrettyPrint as Disp -import GHC.Generics (Generic) -- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). newtype Timestamp = TS Int64 -- Tar.EpochTime @@ -98,9 +97,8 @@ where showTOD = show . timeToTimeOfDay -instance Binary Timestamp where - put (TS t) = put t - get = TS `fmap` get +instance Binary Timestamp +instance Structured Timestamp instance Text Timestamp where disp = Disp.text . showTimestamp @@ -177,6 +175,7 @@ deriving (Eq,Generic,Show) instance Binary IndexState +instance Structured IndexState instance NFData IndexState instance Text IndexState where diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -37,7 +37,8 @@ ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) import Data.List - ( groupBy, (\\) ) + ( (\\) ) +import qualified Data.List.NonEmpty as NE import Data.Function ( on ) import qualified Data.Map as M @@ -636,25 +637,25 @@ -- do it. grps -> do message flags ("\nWarning: multiple packages found providing " ++ display m - ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps)) + ++ ": " ++ intercalate ", " (fmap (display . P.pkgName . NE.head) grps)) message flags "You will need to pick one and manually add it to the Build-depends: field." return Nothing where - pkgGroups = groupBy ((==) `on` P.pkgName) (map P.packageId ps) + pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps) desugar = maybe True (< mkVersion [2]) $ flagToMaybe (cabalVersion flags) -- Given a list of available versions of the same package, pick a dependency. - toDep :: [P.PackageIdentifier] -> IO P.Dependency + toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency -- If only one version, easy. We change e.g. 0.4.2 into 0.4.* - toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries + toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries -- Otherwise, choose the latest version and issue a warning. toDep pids = do - message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") - return $ P.Dependency (P.pkgName . head $ pids) - (pvpize desugar . maximum . map P.pkgVersion $ pids) + message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . NE.head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.") + return $ P.Dependency (P.pkgName . NE.head $ pids) + (pvpize desugar . maximum . fmap P.pkgVersion $ pids) (Set.singleton LMainLibName) --TODO take into account sublibraries -- | Given a version, return an API-compatible (according to PVP) version range. @@ -950,7 +951,9 @@ _ -> writeMainHs flags mainFile else return () where - Flag mainFile = mainIs flags + mainFile = case mainIs flags of + Flag x -> x + NoFlag -> error "createMainHs: no mainIs" --- | Write a main file if it doesn't already exist. writeMainHs :: InitFlags -> FilePath -> IO () diff --git a/Distribution/Client/Init/Heuristics.hs b/Distribution/Client/Init/Heuristics.hs --- a/Distribution/Client/Init/Heuristics.hs +++ b/Distribution/Client/Init/Heuristics.hs @@ -22,6 +22,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic (safeHead, safeTail, safeLast) import Distribution.Parsec (simpleParsec) import Distribution.Simple.Setup (Flag(..), flagToMaybe) @@ -56,6 +57,8 @@ import Distribution.Client.Compat.Process ( readProcessWithExitCode ) import System.Exit ( ExitCode(..) ) +import qualified Distribution.Utils.ShortText as ShortText + -- | Return a list of candidate main files for this executable: top-level -- modules including the word 'Main' in the file name. The list is sorted in -- order of preference, shorter file names are preferred. 'Right's are existing @@ -86,7 +89,7 @@ -- | Guess the package name based on the given root directory. guessPackageName :: FilePath -> IO P.PackageName -guessPackageName = liftM (P.mkPackageName . repair . last . splitDirectories) +guessPackageName = liftM (P.mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) . tryCanonicalizePath where -- Treat each span of non-alphanumeric characters as a hyphen. Each @@ -132,7 +135,7 @@ (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries) let modules = catMaybes [ guessModuleName hierarchy file | file <- files - , isUpper (head file) ] + , maybe False isUpper (safeHead file) ] modules' <- mapM (findImportsAndExts projectRoot) modules recMods <- mapM (scanRecursive dir hierarchy) dirs return $ concat (modules' : recMods) @@ -151,8 +154,8 @@ $ intercalate "." . reverse $ (unqualModName : hierarchy) ext = case takeExtension entry of '.':e -> e; e -> e scanRecursive parent hierarchy entry - | isUpper (head entry) = scan (parent entry) (entry : hierarchy) - | isLower (head entry) && not (ignoreDir entry) = + | maybe False isUpper (safeHead entry) = scan (parent entry) (entry : hierarchy) + | maybe False isLower (safeHead entry) && not (ignoreDir entry) = scanForModulesIn projectRoot $ foldl () srcRoot (reverse (entry : hierarchy)) | otherwise = return [] ignoreDir ('.':_) = True @@ -345,9 +348,9 @@ -- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached knownCategories :: SourcePackageDb -> [String] knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet - [ cat | pkg <- map head (allPackagesByName sourcePkgIndex) + [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex) , let catList = (PD.category . PD.packageDescription . packageDescription) pkg - , cat <- splitString ',' catList + , cat <- splitString ',' $ ShortText.fromShortText catList ] -- Parse name and email, from darcs pref files or environment variable @@ -358,7 +361,7 @@ | otherwise = (Flag $ trim nameOrEmail, Flag mail) where (nameOrEmail,erest) = break (== '<') str - (mail,_) = break (== '>') (tail erest) + (mail,_) = break (== '>') (safeTail erest) trim :: String -> String trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -31,7 +31,9 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic(safeLast) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as S import Control.Exception as Exception @@ -124,7 +126,7 @@ import Distribution.Simple.Setup ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags - , TestFlags + , TestFlags, BenchmarkFlags , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) @@ -133,7 +135,7 @@ , testCommand, TestFlags(..) ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, comparing - , writeFileAtomic, withUTF8FileContents ) + , writeFileAtomic ) import Distribution.Simple.InstallDirs as InstallDirs ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) @@ -147,7 +149,7 @@ ( thisPackageVersion ) import Distribution.Types.GivenComponent ( GivenComponent(..) ) -import Distribution.Pretty ( prettyShow ) +import Distribution.Pretty ( prettyShow ) import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint(..) ) import Distribution.Types.MungedPackageId @@ -172,6 +174,8 @@ ( Verbosity, modifyVerbosity, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension ) +import qualified Data.ByteString as BS + --TODO: -- * assign flags to packages individually -- * complain about flags that do not apply to any package given as target @@ -205,11 +209,12 @@ -> InstallFlags -> HaddockFlags -> TestFlags + -> BenchmarkFlags -> [UserTarget] -> IO () install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgInfo - globalFlags configFlags configExFlags installFlags haddockFlags testFlags - userTargets0 = do + globalFlags configFlags configExFlags installFlags + haddockFlags testFlags benchmarkFlags userTargets0 = do unless (installRootCmd installFlags == Cabal.NoFlag) $ warn verbosity $ "--root-cmd is no longer supported, " @@ -237,7 +242,7 @@ args :: InstallArgs args = (packageDBs, repos, comp, platform, progdb, useSandbox, mSandboxPkgInfo, globalFlags, configFlags, configExFlags, - installFlags, haddockFlags, testFlags) + installFlags, haddockFlags, testFlags, benchmarkFlags) die'' message = die' verbosity (message ++ if isUseSandbox useSandbox then installFailedInSandbox else []) @@ -271,14 +276,15 @@ , ConfigExFlags , InstallFlags , HaddockFlags - , TestFlags ) + , TestFlags + , BenchmarkFlags ) -- | Make an install context given install arguments. makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext makeInstallContext verbosity (packageDBs, repoCtxt, comp, _, progdb,_,_, - globalFlags, _, configExFlags, installFlags, _, _) mUserTargets = do + globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do let idxState = flagToMaybe (installIndexState installFlags) @@ -317,7 +323,7 @@ makeInstallPlan verbosity (_, _, comp, platform, _, _, mSandboxPkgInfo, _, configFlags, configExFlags, installFlags, - _, _) + _, _, _) (installedPkgIndex, sourcePkgDb, pkgConfigDb, _, pkgSpecifiers, _) = do @@ -333,7 +339,7 @@ -> SolverInstallPlan -> IO () processInstallPlan verbosity - args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _, _) + args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _, _, _) (installedPkgIndex, sourcePkgDb, _, userTargets, pkgSpecifiers, _) installPlan0 = do @@ -389,6 +395,8 @@ . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts + . setMinimizeConflictSet minimizeConflictSet . setAvoidReinstalls avoidReinstalls @@ -457,6 +465,7 @@ fromFlag (installReinstall installFlags) reorderGoals = fromFlag (installReorderGoals installFlags) countConflicts = fromFlag (installCountConflicts installFlags) + fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) independentGoals = fromFlag (installIndependentGoals installFlags) avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) @@ -698,11 +707,11 @@ Nothing -> "" where mLatestVersion :: Maybe Version - mLatestVersion = case SourcePackageIndex.lookupPackageName - (packageIndex sourcePkgDb) - (packageName pkg) of - [] -> Nothing - x -> Just $ packageVersion $ last x + mLatestVersion = fmap packageVersion $ + safeLast $ + SourcePackageIndex.lookupPackageName + (packageIndex sourcePkgDb) + (packageName pkg) toFlagAssignment :: [Flag] -> FlagAssignment toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f)) @@ -754,7 +763,7 @@ -> IO () reportPlanningFailure verbosity (_, _, comp, platform, _, _, _ - ,_, configFlags, _, installFlags, _, _) + ,_, configFlags, _, installFlags, _, _, _) (_, sourcePkgDb, _, _, pkgSpecifiers, _) message = do @@ -834,7 +843,7 @@ -> IO () postInstallActions verbosity (packageDBs, _, comp, platform, progdb, useSandbox, mSandboxPkgInfo - ,globalFlags, configFlags, _, installFlags, _, _) + ,globalFlags, configFlags, _, installFlags, _, _, _) targets installPlan buildOutcomes = do updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo @@ -1088,7 +1097,8 @@ -> IO BuildOutcomes performInstallations verbosity (packageDBs, repoCtxt, comp, platform, progdb, useSandbox, _, - globalFlags, configFlags, configExFlags, installFlags, haddockFlags, testFlags) + globalFlags, configFlags, configExFlags, installFlags, + haddockFlags, testFlags, _) installedPkgIndex installPlan = do -- With 'install -j' it can be a bit hard to tell whether a sandbox is used. @@ -1546,14 +1556,14 @@ readPkgConf :: FilePath -> FilePath -> IO Installed.InstalledPackageInfo - readPkgConf pkgConfDir pkgConfFile = - (withUTF8FileContents (pkgConfDir pkgConfFile) $ \pkgConfText -> - case Installed.parseInstalledPackageInfo pkgConfText of - Left perrors -> pkgConfParseFailed $ unlines perrors - Right (warns, pkgConf) -> do - unless (null warns) $ - warn verbosity $ unlines warns - return pkgConf) + readPkgConf pkgConfDir pkgConfFile = do + pkgConfText <- BS.readFile (pkgConfDir pkgConfFile) + case Installed.parseInstalledPackageInfo pkgConfText of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, pkgConf) -> do + unless (null warns) $ + warn verbosity $ unlines warns + return pkgConf pkgConfParseFailed :: String -> IO a pkgConfParseFailed perror = diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -67,6 +67,10 @@ reverseDependencyClosure, ) where +import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail) +import Prelude (tail) +import Distribution.Compat.Stack (WithCallStack) + import Distribution.Client.Types hiding (BuildOutcomes) import qualified Distribution.PackageDescription as PD import qualified Distribution.Simple.Configure as Configure @@ -80,6 +84,7 @@ import Distribution.Solver.Types.SolverPackage import Distribution.Client.JobControl import Distribution.Deprecated.Text +import Distribution.Pretty (prettyShow) import Text.PrettyPrint import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.SolverInstallPlan (SolverInstallPlan) @@ -90,31 +95,19 @@ import Distribution.Solver.Types.InstSolverPackage import Distribution.Utils.LogProgress +import Distribution.Utils.Structured (Structured (..), Structure(Nominal)) -- TODO: Need this when we compute final UnitIds -- import qualified Distribution.Simple.Configure as Configure -import Data.List - ( foldl', intercalate ) -import qualified Data.Foldable as Foldable (all) -import Data.Maybe - ( fromMaybe, mapMaybe ) +import qualified Data.Foldable as Foldable (all, toList) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..)) -import Distribution.Compat.Binary (Binary(..)) -import GHC.Generics -import Data.Typeable -import Control.Monad import Control.Exception ( assert ) import qualified Data.Map as Map -import Data.Map (Map) import qualified Data.Set as Set -import Data.Set (Set) -import Prelude hiding (lookup) - - -- When cabal tries to install a number of packages, including all their -- dependencies it has a non-trivial problem to solve. -- @@ -174,6 +167,11 @@ | Installed srcpkg deriving (Eq, Show, Generic) +displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String +displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) + -- | Convenience combinator for destructing 'GenericPlanPackage'. -- This is handy because if you case manually, you have to handle -- 'Configured' and 'Installed' separately (where often you want @@ -203,8 +201,8 @@ nodeNeighbors (Configured spkg) = nodeNeighbors spkg nodeNeighbors (Installed spkg) = nodeNeighbors spkg -instance (Binary ipkg, Binary srcpkg) - => Binary (GenericPlanPackage ipkg srcpkg) +instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg) +instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg) type PlanPackage = GenericPlanPackage InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) @@ -258,27 +256,34 @@ planIndepGoals = indepGoals } -internalError :: String -> String -> a +internalError :: WithCallStack (String -> String -> a) internalError loc msg = error $ "internal error in InstallPlan." ++ loc ++ if null msg then "" else ": " ++ msg +instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where + structure p = Nominal (typeRep p) 0 "GenericInstallPlan" + [ structure (Proxy :: Proxy ipkg) + , structure (Proxy :: Proxy srcpkg) + ] + instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, Binary ipkg, Binary srcpkg) => Binary (GenericInstallPlan ipkg srcpkg) where put GenericInstallPlan { planGraph = graph, planIndepGoals = indepGoals - } = put (graph, indepGoals) + } = put graph >> put indepGoals get = do - (graph, indepGoals) <- get + graph <- get + indepGoals <- get return $! mkInstallPlan "(instance Binary)" graph indepGoals showPlanGraph :: (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) => Graph (GenericPlanPackage ipkg srcpkg) -> String showPlanGraph graph = renderStyle defaultStyle $ - vcat (map dispPlanPackage (Graph.toList graph)) + vcat (map dispPlanPackage (Foldable.toList graph)) where dispPlanPackage p = hang (hsep [ text (showPlanPackageTag p) , disp (packageId p) @@ -309,7 +314,7 @@ toList :: GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] -toList = Graph.toList . planGraph +toList = Foldable.toList . planGraph toMap :: GenericInstallPlan ipkg srcpkg -> Map UnitId (GenericPlanPackage ipkg srcpkg) @@ -621,7 +626,7 @@ -- and return any packages that are newly in the processing state (ie ready to -- process), along with the updated 'Processing' state. -- -completed :: (IsUnit ipkg, IsUnit srcpkg) +completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> Processing -> UnitId -> ([GenericReadyPackage srcpkg], Processing) @@ -646,8 +651,9 @@ (map nodeKey newlyReady) processing' = Processing processingSet' completedSet' failedSet - asReadyPackage (Configured pkg) = ReadyPackage pkg - asReadyPackage _ = internalError "completed" "" + asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg + asReadyPackage (Configured pkg) = ReadyPackage pkg + asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg failed :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg @@ -673,7 +679,7 @@ processing' = Processing processingSet' completedSet failedSet' asConfiguredPackage (Configured pkg) = pkg - asConfiguredPackage _ = internalError "failed" "not in configured state" + asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg @@ -929,7 +935,7 @@ --TODO: consider re-enabling this one, see SolverInstallPlan -} ++ [ PackageStateInvalid pkg pkg' - | pkg <- Graph.toList graph + | pkg <- Foldable.toList graph , Just pkg' <- map (flip Graph.lookup graph) (nodeNeighbors pkg) , not (stateDependencyRelation pkg pkg') ] diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -22,6 +22,8 @@ import Distribution.Compat.Binary ( Binary ) +import Distribution.Utils.Structured + ( Structured ) import Distribution.Package (PackageIdentifier) import Distribution.Types.UnqualComponentName @@ -37,6 +39,7 @@ deriving (Show, Eq, Generic, Bounded, Enum) instance Binary OverwritePolicy +instance Structured OverwritePolicy symlinkBinaries :: Platform -> Compiler -> OverwritePolicy @@ -48,7 +51,7 @@ symlinkBinaries _ _ _ _ _ _ _ = return [] symlinkBinary :: OverwritePolicy - -> FilePath -> FilePath -> UnqualComponentName -> String + -> FilePath -> FilePath -> FilePath -> String -> IO Bool symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows" @@ -56,6 +59,8 @@ import Distribution.Compat.Binary ( Binary ) +import Distribution.Utils.Structured + ( Structured ) import Distribution.Client.Types ( ConfiguredPackage(..), BuildOutcomes ) @@ -110,6 +115,7 @@ deriving (Show, Eq, Generic, Bounded, Enum) instance Binary OverwritePolicy +instance Structured OverwritePolicy -- | We would like by default to install binaries into some location that is on -- the user's PATH. For per-user installations on Unix systems that basically @@ -154,7 +160,7 @@ ok <- symlinkBinary overwritePolicy publicBinDir privateBinDir - publicExeName privateExeName + (display publicExeName) privateExeName if ok then return Nothing else return (Just (pkgid, publicExeName, @@ -220,7 +226,7 @@ -- @/home/user/bin@ -> FilePath -- ^ The canonical path of the private bin dir eg -- @/home/user/.cabal/bin@ - -> UnqualComponentName -- ^ The name of the executable to go in the public bin + -> FilePath -- ^ The name of the executable to go in the public bin -- dir, eg @foo@ -> String -- ^ The name of the executable to in the private bin -- dir, eg @foo-1.0@ @@ -229,7 +235,7 @@ -- not own. Other errors like permission errors just -- propagate as exceptions. symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do - ok <- targetOkToOverwrite (publicBindir publicName') + ok <- targetOkToOverwrite (publicBindir publicName) (privateBindir privateName) case ok of NotExists -> mkLink >> return True @@ -239,11 +245,10 @@ NeverOverwrite -> return False AlwaysOverwrite -> rmLink >> mkLink >> return True where - publicName' = display publicName relativeBindir = makeRelative publicBindir privateBindir mkLink = createSymbolicLink (relativeBindir privateName) - (publicBindir publicName') - rmLink = removeLink (publicBindir publicName') + (publicBindir publicName) + rmLink = removeLink (publicBindir publicName) -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -77,7 +77,10 @@ import System.Directory ( doesDirectoryExist ) +import Distribution.Utils.ShortText (ShortText) +import qualified Distribution.Utils.ShortText as ShortText + -- | Return a list of packages matching given search strings. getPkgList :: Verbosity -> PackageDBStack @@ -277,15 +280,15 @@ installedVersions :: [Version], sourceVersions :: [Version], preferredVersions :: VersionRange, - homepage :: String, - bugReports :: String, - sourceRepo :: String, - synopsis :: String, - description :: String, - category :: String, + homepage :: ShortText, + bugReports :: ShortText, + sourceRepo :: String, -- TODO + synopsis :: ShortText, + description :: ShortText, + category :: ShortText, license :: Either SPDX.License License, - author :: String, - maintainer :: String, + author :: ShortText, + maintainer :: ShortText, dependencies :: [ExtDependency], flags :: [Flag], hasLib :: Bool, @@ -307,7 +310,7 @@ char '*' <+> disp (pkgName pkginfo) $+$ (nest 4 $ vcat [ - maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs + maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs , text "Default available version:" <+> case selectedSourcePkg pkginfo of Nothing -> text "[ Not available from any configured repository ]" @@ -318,13 +321,14 @@ | otherwise -> text "[ Unknown ]" versions -> dispTopVersions 4 (preferredVersions pkginfo) versions - , maybeShow (homepage pkginfo) "Homepage:" text + , maybeShowST (homepage pkginfo) "Homepage:" text , text "License: " <+> either pretty pretty (license pkginfo) ]) $+$ text "" where - maybeShow [] _ _ = empty - maybeShow l s f = text s <+> (f l) + maybeShowST l s f + | ShortText.null l = empty + | otherwise = text s <+> f (ShortText.fromShortText l) showPackageDetailedInfo :: PackageDisplayInfo -> String showPackageDetailedInfo pkginfo = @@ -335,7 +339,7 @@ Disp.<> parens pkgkind $+$ (nest 4 $ vcat [ - entry "Synopsis" synopsis hideIfNull reflowParagraphs + entryST "Synopsis" synopsis hideIfNull reflowParagraphs , entry "Versions available" sourceVersions (altText null "[ Not available from server ]") (dispTopVersions 9 (preferredVersions pkginfo)) @@ -343,13 +347,13 @@ (altText null (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")) (dispTopVersions 4 (preferredVersions pkginfo)) - , entry "Homepage" homepage orNotSpecified text - , entry "Bug reports" bugReports orNotSpecified text - , entry "Description" description hideIfNull reflowParagraphs - , entry "Category" category hideIfNull text + , entryST "Homepage" homepage orNotSpecified text + , entryST "Bug reports" bugReports orNotSpecified text + , entryST "Description" description hideIfNull reflowParagraphs + , entryST "Category" category hideIfNull text , entry "License" license alwaysShow (either pretty pretty) - , entry "Author" author hideIfNull reflowLines - , entry "Maintainer" maintainer hideIfNull reflowLines + , entryST "Author" author hideIfNull reflowLines + , entryST "Maintainer" maintainer hideIfNull reflowLines , entry "Source repo" sourceRepo orNotSpecified text , entry "Executables" executables hideIfNull (commaSep disp) , entry "Flags" flags hideIfNull (commaSep dispFlag) @@ -369,6 +373,8 @@ label = text fname Disp.<> char ':' Disp.<> padding padding = text (replicate (13 - length fname ) ' ') + entryST fname field = entry fname (ShortText.fromShortText . field) + normal = Nothing hide = Just Nothing replace msg = Just (Just msg) @@ -446,14 +452,14 @@ Installed.author installed, homepage = combine Source.homepage source Installed.homepage installed, - bugReports = maybe "" Source.bugReports source, - sourceRepo = fromMaybe "" . join + bugReports = maybe mempty Source.bugReports source, + sourceRepo = fromMaybe mempty . join . fmap (uncons Nothing Source.repoLocation . sortBy (comparing Source.repoKind) . Source.sourceRepos) $ source, --TODO: installed package info is missing synopsis - synopsis = maybe "" Source.synopsis source, + synopsis = maybe mempty Source.synopsis source, description = combine Source.description source Installed.description installed, category = combine Source.category source diff --git a/Distribution/Client/Outdated.hs b/Distribution/Client/Outdated.hs --- a/Distribution/Client/Outdated.hs +++ b/Distribution/Client/Outdated.hs @@ -26,6 +26,7 @@ import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackageIndex import Distribution.Client.Sandbox.PackageEnvironment +import Distribution.Utils.Generic import Distribution.Package (PackageName, packageVersion) import Distribution.PackageDescription (allBuildDepends) @@ -204,7 +205,8 @@ relaxMinor :: VersionRange -> VersionRange relaxMinor vr = let vis = asVersionIntervals vr - (LowerBound v0 _,upper) = last vis - in case upper of - NoUpperBound -> vr - UpperBound _v1 _ -> majorBoundVersion v0 + in maybe vr relax (safeLast vis) + where relax (LowerBound v0 _, upper) = + case upper of + NoUpperBound -> vr + UpperBound _v1 _ -> majorBoundVersion v0 diff --git a/Distribution/Client/PackageHash.hs b/Distribution/Client/PackageHash.hs --- a/Distribution/Client/PackageHash.hs +++ b/Distribution/Client/PackageHash.hs @@ -20,13 +20,6 @@ -- ** Platform-specific variations hashedInstalledPackageIdLong, hashedInstalledPackageIdShort, - - -- * Low level hash choice - HashValue, - hashValue, - showHashValue, - readFileHashValue, - hashFromTUF, ) where import Prelude () @@ -48,25 +41,17 @@ import Distribution.Deprecated.Text ( display ) import Distribution.Types.PkgconfigVersion (PkgconfigVersion) +import Distribution.Client.HashValue import Distribution.Client.Types ( InstalledPackageId ) import qualified Distribution.Solver.Types.ComponentDeps as CD -import qualified Hackage.Security.Client as Sec - -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Set (Set) import Data.Function (on) -import Control.Exception (evaluate) -import System.IO (withBinaryFile, IOMode(..)) - ------------------------------- -- Calculating package hashes -- @@ -122,15 +107,11 @@ -- max length now 64 [ truncateStr 14 (display name) , truncateStr 8 (display version) - , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs)) + , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs)) ] where PackageIdentifier name version = pkgHashPkgId - -- Truncate a 32 byte SHA256 hash to 160bits, 20 bytes :-( - -- It'll render as 40 hex chars. - truncateHash (HashValue h) = HashValue (BS.take 20 h) - -- Truncate a string, with a visual indication that it is truncated. truncateStr n s | length s <= n = s | otherwise = take (n-1) s ++ "_" @@ -164,11 +145,10 @@ intercalate "-" [ filter (not . flip elem "aeiou") (display name) , display version - , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs)) + , showHashValue (truncateHash 4 (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'. @@ -331,58 +311,3 @@ | otherwise = entry key format value showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment - ------------------------------------------------ --- The specific choice of hash implementation --- - --- Is a crypto hash necessary here? One thing to consider is who controls the --- inputs and what's the result of a hash collision. Obviously we should not --- install packages we don't trust because they can run all sorts of code, but --- if I've checked there's no TH, no custom Setup etc, is there still a --- problem? If someone provided us a tarball that hashed to the same value as --- some other package and we installed it, we could end up re-using that --- installed package in place of another one we wanted. So yes, in general --- there is some value in preventing intentional hash collisions in installed --- package ids. - -newtype HashValue = HashValue BS.ByteString - deriving (Eq, Generic, Show, Typeable) - -instance Binary HashValue where - put (HashValue digest) = put digest - get = do - digest <- get - -- Cannot do any sensible validation here. Although we use SHA256 - -- for stuff we hash ourselves, we can also get hashes from TUF - -- and that can in principle use different hash functions in future. - return (HashValue digest) - --- | Hash some data. Currently uses SHA256. --- -hashValue :: LBS.ByteString -> HashValue -hashValue = HashValue . SHA256.hashlazy - -showHashValue :: HashValue -> String -showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) - --- | Hash the content of a file. Uses SHA256. --- -readFileHashValue :: FilePath -> IO HashValue -readFileHashValue tarball = - withBinaryFile tarball ReadMode $ \hnd -> - evaluate . hashValue =<< LBS.hGetContents hnd - --- | Convert a hash from TUF metadata into a 'PackageSourceHash'. --- --- Note that TUF hashes don't neessarily have to be SHA256, since it can --- support new algorithms in future. --- -hashFromTUF :: Sec.Hash -> HashValue -hashFromTUF (Sec.Hash hashstr) = - --TODO: [code cleanup] either we should get TUF to use raw bytestrings or - -- perhaps we should also just use a base16 string as the internal rep. - case Base16.decode (BS.pack hashstr) of - (hash, trailing) | not (BS.null hash) && BS.null trailing - -> HashValue hash - _ -> error "hashFromTUF: cannot decode base16 hash" diff --git a/Distribution/Client/ParseUtils.hs b/Distribution/Client/ParseUtils.hs --- a/Distribution/Client/ParseUtils.hs +++ b/Distribution/Client/ParseUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-} +{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-} ----------------------------------------------------------------------------- -- | @@ -24,6 +24,9 @@ SectionDescr(..), liftSection, + -- * FieldGrammar sections + FGSectionDescr(..), + -- * Parsing and printing flat config parseFields, ppFields, @@ -39,6 +42,9 @@ ) where +import Distribution.Client.Compat.Prelude hiding (empty, get) +import Prelude () + import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo , Field(..), liftField, readFieldsFlat ) @@ -48,13 +54,23 @@ import Distribution.Simple.Command ( OptionField ) -import Control.Monad ( foldM ) import Text.PrettyPrint ( (<+>), ($+$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) +-- For new parser stuff +import Distribution.CabalSpecVersion (cabalSpecLatest) +import Distribution.FieldGrammar (FieldGrammar, partitionFields, parseFieldGrammar) +import Distribution.Fields.ParseResult (runParseResult) +import Distribution.Parsec.Error (showPError) +import Distribution.Parsec.Position (Position (..)) +import Distribution.Parsec.Warning (showPWarning) +import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) +import qualified Distribution.Fields as F +import qualified Distribution.FieldGrammar as FG + ------------------------- -- FieldDescr utilities -- @@ -107,6 +123,15 @@ sectionEmpty :: b } +-- | 'FieldGrammar' section description +data FGSectionDescr a = forall s. FGSectionDescr + { fgSectionName :: String + , fgSectionGrammar :: forall g. (FieldGrammar g, Applicative (g s)) => g s s + -- todo: add subsections? + , fgSectionGet :: a -> [(String, s)] + , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a + } + -- | To help construction of config file descriptions in a modular way it is -- useful to define fields and sections on local types and then hoist them -- into the parent types when combining them in bigger descriptions. @@ -191,13 +216,18 @@ -- | Much like 'parseFields' but it also allows subsections. The permitted -- subsections are given by a list of 'SectionDescr's. -- -parseFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a - -> [Field] -> ParseResult a -parseFieldsAndSections fieldDescrs sectionDescrs = +parseFieldsAndSections + :: [FieldDescr a] -- ^ field + -> [SectionDescr a] -- ^ legacy sections + -> [FGSectionDescr a] -- ^ FieldGrammar sections + -> a + -> [Field] -> ParseResult a +parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = foldM setField where - fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] - sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ] + fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ] + sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ] + fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ] setField a (F line name value) = case Map.lookup name fieldMap of @@ -208,10 +238,25 @@ return a setField a (Section line name param fields) = - case Map.lookup name sectionMap of - Just (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty) -> do - b <- parseFieldsAndSections fieldDescrs' sectionDescrs' sectionEmpty fields + case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of + Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do + b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields set line param b a + Just (Right (FGSectionDescr _ grammar _getter setter)) -> do + let fields1 = mapMaybe convertField fields + (fields2, sections) = partitionFields fields1 + -- TODO: recurse into sections + for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) -> + warning $ "Unrecognized section '" ++ fromUTF8BS name' + ++ "' on line " ++ show line' + case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of + (warnings, Right b) -> do + for_ warnings $ \w -> warning $ showPWarning "???" w + setter line param b a + (warnings, Left (_, errs)) -> do + for_ warnings $ \w -> warning $ showPWarning "???" w + case errs of + err :| _errs -> fail $ showPError "???" err Nothing -> do warning $ "Unrecognized section '" ++ name ++ "' on line " ++ show line @@ -221,17 +266,31 @@ warning $ "Unrecognized stanza on line " ++ show (lineNo block) return accum +convertField :: Field -> Maybe (F.Field Position) +convertField (F line name str) = Just $ + F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ] + where + pos = Position line 0 +-- arguments omitted +convertField (Section line name _arg fields) = Just $ + F.Section (F.Name pos (toUTF8BS name)) [] (mapMaybe convertField fields) + where + pos = Position line 0 +-- silently omitted. +convertField IfBlock {} = Nothing + + -- | Much like 'ppFields' but also pretty prints any subsections. Subsection -- are only shown if they are non-empty. -- -- Note that unlike 'ppFields', at present it does not support printing -- default values. If needed, adding such support would be quite reasonable. -- -ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc -ppFieldsAndSections fieldDescrs sectionDescrs val = +ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc +ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val = ppFields fieldDescrs Nothing val $+$ - Disp.vcat + Disp.vcat ( [ Disp.text "" $+$ sectionDoc | SectionDescr { sectionName, sectionGet, @@ -240,25 +299,58 @@ , (param, x) <- sectionGet val , let sectionDoc = ppSectionAndSubsections sectionName param - sectionFields sectionSubsections x + sectionFields sectionSubsections [] x , not (Disp.isEmpty sectionDoc) - ] + ] ++ + [ Disp.text "" $+$ sectionDoc + | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs + , (param, x) <- fgSectionGet val + , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x + , not (Disp.isEmpty sectionDoc) + ]) -- | Unlike 'ppSection' which has to be called directly, this gets used via -- 'ppFieldsAndSections' and so does not need to be exported. -- ppSectionAndSubsections :: String -> String - -> [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc -ppSectionAndSubsections name arg fields sections cur + -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc +ppSectionAndSubsections name arg fields sections fgSections cur | Disp.isEmpty fieldsDoc = Disp.empty | otherwise = Disp.text name <+> argDoc $+$ (Disp.nest 2 fieldsDoc) where - fieldsDoc = showConfig fields sections cur + fieldsDoc = showConfig fields sections fgSections cur argDoc | arg == "" = Disp.empty | otherwise = Disp.text arg +-- | +-- +-- TODO: subsections +-- TODO: this should simply build 'PrettyField' +ppFgSection + :: String -- ^ section name + -> String -- ^ parameter + -> FG.PrettyFieldGrammar a a + -> a + -> Disp.Doc +ppFgSection secName arg grammar x + | null prettyFields = Disp.empty + | otherwise = + Disp.text secName <+> argDoc + $+$ (Disp.nest 2 fieldsDoc) + where + prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x + argDoc | arg == "" = Disp.empty + | otherwise = Disp.text arg + + fieldsDoc = Disp.vcat + [ Disp.text fname' <<>> Disp.colon <<>> doc + | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections + , let fname' = fromUTF8BS fname + ] + + ----------------------------------------------- -- Top level config file parsing and printing -- @@ -268,15 +360,15 @@ -- -- It accumulates the result on top of a given initial (typically empty) value. -- -parseConfig :: [FieldDescr a] -> [SectionDescr a] -> a +parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> String -> ParseResult a -parseConfig fieldDescrs sectionDescrs empty str = - parseFieldsAndSections fieldDescrs sectionDescrs empty +parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str = + parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty =<< readFieldsFlat str -- | Render a value in the config file syntax, based on a description of the -- configuration file in terms of its fields and sections. -- -showConfig :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc +showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc showConfig = ppFieldsAndSections diff --git a/Distribution/Client/ProjectBuilding.hs b/Distribution/Client/ProjectBuilding.hs --- a/Distribution/Client/ProjectBuilding.hs +++ b/Distribution/Client/ProjectBuilding.hs @@ -38,9 +38,8 @@ BuildFailureReason(..), ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif +import Distribution.Client.Compat.Prelude +import Prelude () import Distribution.Client.PackageHash (renderPackageHashInputs) import Distribution.Client.RebuildMonad @@ -95,28 +94,20 @@ import Distribution.Pretty import Distribution.Compat.Graph (IsNode(..)) -import Data.Map (Map) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import Data.List (isPrefixOf) -import Control.Monad -import Control.Exception -import Data.Function (on) -import Data.Maybe +import Control.Exception (Exception (..), Handler (..), SomeAsyncException, SomeException, assert, catches, handle, throwIO) +import Data.Function (on) +import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) +import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), ()) +import System.IO (IOMode (AppendMode), withFile) -import System.FilePath -import System.IO -import System.Directory +import Distribution.Compat.Directory (listDirectory) -#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. @@ -272,7 +263,7 @@ -- -- The packages are visited in dependency order, starting with packages with no -- dependencies. The result for each package is accumulated into a 'Map' and --- returned as the final result. In addition, when visting a package, the +-- returned as the final result. In addition, when visiting a package, the -- visiting function is passed the results for all the immediate package -- dependencies. This can be used to propagate information from dependencies. -- @@ -295,7 +286,7 @@ -- we go in the right order so the results map has entries for all deps let depresults :: [b] depresults = - map (\ipkgid -> let Just result = Map.lookup ipkgid results + map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results in result) (InstallPlan.depends pkg) result <- visit pkg depresults @@ -590,7 +581,7 @@ createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory createDirectoryIfMissingVerbose verbosity True distTempDirectory - mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse + traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse -- Before traversing the install plan, pre-emptively find all packages that -- will need to be downloaded and start downloading them. @@ -605,7 +596,7 @@ handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ let uid = installedUnitId pkg - Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in + pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in rebuildTarget verbosity @@ -765,7 +756,7 @@ | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan , let uid = installedUnitId elab - Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus + pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus , BuildStatusDownload <- [pkgBuildStatus] ] @@ -983,6 +974,12 @@ let prefix = normalise $ dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) entryDir = tmpDirNormalised prefix + + -- if there weren't anything to build, it might be that directory is not created + -- the @setup Cabal.copyCommand@ above might do nothing. + -- https://github.com/haskell/cabal/issues/4130 + createDirectoryIfMissingVerbose verbosity True entryDir + LBS.writeFile (entryDir "cabal-hash.txt") (renderPackageHashInputs (packageHashInputs pkgshared pkg)) @@ -1007,7 +1004,7 @@ listFilesRecursive :: FilePath -> IO [FilePath] listFilesRecursive path = do files <- fmap (path ) <$> (listDirectory path) - allFiles <- forM files $ \file -> do + allFiles <- for files $ \file -> do isDir <- doesDirectoryExist file if isDir then listFilesRecursive file @@ -1441,11 +1438,10 @@ ++ show perror readPkgConf pkgConfDir pkgConfFile = do - (warns, ipkg) <- - withUTF8FileContents (pkgConfDir pkgConfFile) $ \pkgConfStr -> - case Installed.parseInstalledPackageInfo pkgConfStr of - Left perrors -> pkgConfParseFailed $ unlines perrors - Right (warns, ipkg) -> return (warns, ipkg) + pkgConfStr <- BS.readFile (pkgConfDir pkgConfFile) + (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, ipkg) -> return (warns, ipkg) unless (null warns) $ warn verbosity $ unlines warns diff --git a/Distribution/Client/ProjectConfig.hs b/Distribution/Client/ProjectConfig.hs --- a/Distribution/Client/ProjectConfig.hs +++ b/Distribution/Client/ProjectConfig.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -28,6 +29,7 @@ readGlobalConfig, readProjectLocalFreezeConfig, withProjectOrGlobalConfig, + withProjectOrGlobalConfigIgn, writeProjectLocalExtraConfig, writeProjectLocalFreezeConfig, writeProjectConfigFile, @@ -98,9 +100,11 @@ ( parseGenericPackageDescription ) import Distribution.Fields ( runParseResult, PError, PWarning, showPWarning) -import Distribution.Pretty () +import Distribution.Pretty (prettyShow) import Distribution.Types.SourceRepo - ( SourceRepo(..), RepoType(..), ) + ( RepoType(..) ) +import Distribution.Client.SourceRepo + ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) import Distribution.Simple.Compiler ( Compiler, compilerInfo ) import Distribution.Simple.Program @@ -139,7 +143,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map -import Data.Set (Set) +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Hashable as Hashable import Numeric (showHex) @@ -183,6 +187,7 @@ verbosity buildSettingRemoteRepos buildSettingLocalRepos + buildSettingLocalNoIndexRepos buildSettingCacheDir buildSettingHttpTransport (Just buildSettingIgnoreExpiry) @@ -205,6 +210,7 @@ verbosity (fromNubList projectConfigRemoteRepos) (fromNubList projectConfigLocalRepos) + (fromNubList projectConfigLocalNoIndexRepos) (fromFlagOrDefault (error "projectConfigWithSolverRepoContext: projectConfigCacheDir") @@ -229,6 +235,7 @@ -- the flag assignments need checking. solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos solverSettingLocalRepos = fromNubList projectConfigLocalRepos + solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos solverSettingConstraints = projectConfigConstraints solverSettingPreferences = projectConfigPreferences solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages @@ -243,6 +250,7 @@ | otherwise -> Just n solverSettingReorderGoals = fromFlag projectConfigReorderGoals solverSettingCountConflicts = fromFlag projectConfigCountConflicts + solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet solverSettingStrongFlags = fromFlag projectConfigStrongFlags solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls @@ -264,6 +272,7 @@ projectConfigMaxBackjumps = Flag defaultMaxBackjumps, projectConfigReorderGoals = Flag (ReorderGoals False), projectConfigCountConflicts = Flag (CountConflicts True), + projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True), projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), projectConfigStrongFlags = Flag (StrongFlags False), projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), @@ -292,6 +301,7 @@ projectConfigShared = ProjectConfigShared { projectConfigRemoteRepos, projectConfigLocalRepos, + projectConfigLocalNoIndexRepos, projectConfigProgPathExtra }, projectConfigBuildOnly @@ -312,6 +322,7 @@ buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos buildSettingLocalRepos = fromNubList projectConfigLocalRepos + buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos buildSettingCacheDir = fromFlag projectConfigCacheDir buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry @@ -451,6 +462,24 @@ renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = "The given project file '" ++ projectFile ++ "' does not exist." +-- | Like 'withProjectOrGlobalConfig', with an additional boolean +-- which tells to ignore local project. +-- +-- Used to implement -z / --ignore-project behaviour +-- +withProjectOrGlobalConfigIgn + :: Bool -- ^ whether to ignore local project + -> Verbosity + -> Flag FilePath + -> IO a + -> (ProjectConfig -> IO a) + -> IO a +withProjectOrGlobalConfigIgn True verbosity gcf _with without = do + globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf + without globalConfig +withProjectOrGlobalConfigIgn False verbosity gcf with without = + withProjectOrGlobalConfig verbosity gcf with without + withProjectOrGlobalConfig :: Verbosity -> Flag FilePath -> IO a @@ -647,7 +676,7 @@ | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file | ProjectPackageLocalTarball FilePath | ProjectPackageRemoteTarball URI - | ProjectPackageRemoteRepo SourceRepo + | ProjectPackageRemoteRepo SourceRepoList | ProjectPackageNamed PackageVersionConstraint deriving Show @@ -1055,7 +1084,6 @@ . uncurry (readSourcePackageCabalFile verbosity) =<< extractTarballPackageCabalFile (root tarballFile) - -- | A helper for 'fetchAndReadSourcePackages' to handle the case of -- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir -- and after that handle it like the local tarball case. @@ -1108,7 +1136,7 @@ :: Verbosity -> DistDirLayout -> ProjectConfigShared - -> [SourceRepo] + -> [SourceRepoList] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] syncAndReadSourcePackagesRemoteRepos verbosity DistDirLayout{distDownloadSrcDirectory} @@ -1123,7 +1151,7 @@ -- All 'SourceRepo's grouped by referring to the "same" remote repo -- instance. So same location but can differ in commit/tag/branch/subdir. let reposByLocation :: Map (RepoType, String) - [(SourceRepo, RepoType)] + [(SourceRepoList, RepoType)] reposByLocation = Map.fromListWith (++) [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) | (repo, rloc, rtype, vcs) <- repos' ] @@ -1131,7 +1159,7 @@ --TODO: pass progPathExtra on to 'configureVCS' let _progPathExtra = fromNubList projectConfigProgPathExtra getConfiguredVCS <- delayInitSharedResources $ \repoType -> - let Just vcs = Map.lookup repoType knownVCSs in + let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in configureVCS verbosity {-progPathExtra-} vcs concat <$> sequence @@ -1143,7 +1171,7 @@ pathStem = distDownloadSrcDirectory localFileNameForRemoteRepo primaryRepo monitor :: FileMonitor - [SourceRepo] + [SourceRepoList] [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] monitor = newFileMonitor (pathStem <.> "cache") ] @@ -1151,7 +1179,7 @@ syncRepoGroupAndReadSourcePackages :: VCS ConfiguredProgram -> FilePath - -> [SourceRepo] + -> [SourceRepoList] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do liftIO $ createDirectoryIfMissingVerbose verbosity False @@ -1168,29 +1196,38 @@ sequence [ readPackageFromSourceRepo repoWithSubdir repoPath | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths - , repoWithSubdir <- reposWithSubdir ] + , repoWithSubdir <- NE.toList reposWithSubdir ] where -- So to do both things above, we pair them up here. + repoGroupWithPaths + :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] repoGroupWithPaths = zipWith (\(x, y) z -> (x,y,z)) - (Map.toList - (Map.fromListWith (++) - [ (repo { repoSubdir = Nothing }, [repo]) - | repo <- repoGroup ])) + (mapGroup + [ (repo { srpSubdir = Proxy }, repo) + | repo <- foldMap (NE.toList . srpFanOut) repoGroup + ]) repoPaths + mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)] + mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v)) + -- The repos in a group are given distinct names by simple enumeration -- foo, foo-2, foo-3 etc + repoPaths :: [FilePath] repoPaths = pathStem : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] + readPackageFromSourceRepo + :: SourceRepositoryPackage Maybe -> FilePath + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) readPackageFromSourceRepo repo repoPath = do - let packageDir = maybe repoPath (repoPath ) (repoSubdir repo) + let packageDir = maybe repoPath (repoPath ) (srpSubdir repo) entries <- liftIO $ getDirectoryContents packageDir --TODO: wrap exceptions case filter (\e -> takeExtension e == ".cabal") entries of - [] -> liftIO $ throwIO NoCabalFileFound - (_:_:_) -> liftIO $ throwIO MultipleCabalFilesFound + [] -> liftIO $ throwIO $ NoCabalFileFound packageDir + (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir [cabalFileName] -> do monitorFiles [monitorFileHashed cabalFilePath] liftIO $ fmap (mkSpecificSourcePackage location) @@ -1201,10 +1238,10 @@ location = RemoteSourceRepoPackage repo packageDir - reportSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> Rebuild a + reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems - renderSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> String + renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" @@ -1229,11 +1266,11 @@ -- | Errors reported upon failing to parse a @.cabal@ file. -- data CabalFileParseError = CabalFileParseError - FilePath -- ^ @.cabal@ file path - BS.ByteString -- ^ @.cabal@ file contents - [PError] -- ^ errors - (Maybe Version) -- ^ We might discover the spec version the package needs - [PWarning] -- ^ warnings + FilePath -- ^ @.cabal@ file path + BS.ByteString -- ^ @.cabal@ file contents + (NonEmpty PError) -- ^ errors + (Maybe Version) -- ^ We might discover the spec version the package needs + [PWarning] -- ^ warnings deriving (Typeable) -- | Manual instance which skips file contentes @@ -1282,9 +1319,9 @@ -- | When looking for a package's @.cabal@ file we can find none, or several, -- both of which are failures. -- -data CabalFileSearchFailure = - NoCabalFileFound - | MultipleCabalFilesFound +data CabalFileSearchFailure + = NoCabalFileFound FilePath + | MultipleCabalFilesFound FilePath deriving (Show, Typeable) instance Exception CabalFileSearchFailure @@ -1298,7 +1335,7 @@ extractTarballPackageCabalFile tarballFile = withBinaryFile tarballFile ReadMode $ \hnd -> do content <- LBS.hGetContents hnd - case extractTarballPackageCabalFilePure content of + case extractTarballPackageCabalFilePure tarballFile content of Left (Left e) -> throwIO e Left (Right e) -> throwIO e Right (fileName, fileContent) -> @@ -1307,11 +1344,12 @@ -- | Scan through a tar file stream and collect the @.cabal@ file, or fail. -- -extractTarballPackageCabalFilePure :: LBS.ByteString +extractTarballPackageCabalFilePure :: FilePath + -> LBS.ByteString -> Either (Either Tar.FormatError CabalFileSearchFailure) (FilePath, LBS.ByteString) -extractTarballPackageCabalFilePure = +extractTarballPackageCabalFilePure tarballFile = check . accumEntryMap . Tar.filterEntries isCabalFile @@ -1324,11 +1362,11 @@ check (Left (e, _m)) = Left (Left e) check (Right m) = case Map.elems m of - [] -> Left (Right NoCabalFileFound) + [] -> Left (Right $ NoCabalFileFound tarballFile) [file] -> case Tar.entryContent file of Tar.NormalFile content _ -> Right (Tar.entryPath file, content) - _ -> Left (Right NoCabalFileFound) - _files -> Left (Right MultipleCabalFilesFound) + _ -> Left (Right $ NoCabalFileFound tarballFile) + _files -> Left (Right $ MultipleCabalFilesFound tarballFile) isCabalFile e = case splitPath (Tar.entryPath e) of [ _dir, file] -> takeExtension file == ".cabal" @@ -1356,10 +1394,9 @@ -- This is deterministic based on the source repo identity details, and -- intended to produce non-clashing file names for different repos. -- -localFileNameForRemoteRepo :: SourceRepo -> FilePath -localFileNameForRemoteRepo SourceRepo{repoType, repoLocation, repoModule} = - maybe "" ((++ "-") . mangleName) repoLocation - ++ showHex locationHash "" +localFileNameForRemoteRepo :: SourceRepoList -> FilePath +localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} = + mangleName srpLocation ++ "-" ++ showHex locationHash "" where mangleName = truncateString 10 . dropExtension . takeFileName . dropTrailingPathSeparator @@ -1367,7 +1404,7 @@ -- just the parts that make up the "identity" of the repo locationHash :: Word locationHash = - fromIntegral (Hashable.hash (show repoType, repoLocation, repoModule)) + fromIntegral (Hashable.hash (show srpType, srpLocation)) -- | Truncate a string, with a visual indication that it is truncated. 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 @@ -27,11 +27,12 @@ import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types - ( RemoteRepo(..), emptyRemoteRepo + ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo , AllowNewer(..), AllowOlder(..) ) +import Distribution.Client.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) import Distribution.Client.Config - ( SavedConfig(..), remoteRepoFields ) + ( SavedConfig(..), remoteRepoFields, postProcessRepo ) import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..), defaultClientInstallFlags @@ -41,10 +42,7 @@ import Distribution.Package import Distribution.PackageDescription - ( SourceRepo(..), RepoKind(..) - , dispFlagAssignment ) -import Distribution.Client.SourceRepoParse - ( sourceRepoFieldDescrs ) + ( dispFlagAssignment ) import Distribution.Simple.Compiler ( OptimisationLevel(..), DebugInfoLevel(..) ) import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) ) @@ -53,6 +51,7 @@ , ConfigFlags(..), configureOptions , HaddockFlags(..), haddockOptions, defaultHaddockFlags , TestFlags(..), testOptions', defaultTestFlags + , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags , programDbPaths', splitArgs ) import Distribution.Client.Setup @@ -79,7 +78,7 @@ ( Doc, ($+$) ) import qualified Distribution.Deprecated.ParseUtils as ParseUtils (field) import Distribution.Deprecated.ParseUtils - ( ParseResult(..), PError(..), syntaxError, PWarning(..), warning + ( ParseResult(..), PError(..), syntaxError, PWarning(..) , simpleField, commaNewLineListField, newLineListField, parseTokenQ , parseHaskellString, showToken ) import Distribution.Client.ParseUtils @@ -90,6 +89,9 @@ ( PackageVersionConstraint ) import qualified Data.Map as Map + +import Network.URI (URI (..)) + ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types -- @@ -106,7 +108,7 @@ data LegacyProjectConfig = LegacyProjectConfig { legacyPackages :: [String], legacyPackagesOptional :: [String], - legacyPackagesRepo :: [SourceRepo], + legacyPackagesRepo :: [SourceRepoList], legacyPackagesNamed :: [PackageVersionConstraint], legacySharedConfig :: LegacySharedConfig, @@ -126,7 +128,8 @@ legacyConfigureFlags :: ConfigFlags, legacyInstallPkgFlags :: InstallFlags, legacyHaddockFlags :: HaddockFlags, - legacyTestFlags :: TestFlags + legacyTestFlags :: TestFlags, + legacyBenchmarkFlags :: BenchmarkFlags } deriving Generic instance Monoid LegacyPackageConfig where @@ -168,15 +171,16 @@ -> InstallFlags -> ClientInstallFlags -> HaddockFlags -> TestFlags + -> BenchmarkFlags -> ProjectConfig commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags clientInstallFlags - haddockFlags testFlags = + haddockFlags testFlags benchmarkFlags = mempty { projectConfigBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags installFlags clientInstallFlags - haddockFlags testFlags, + haddockFlags testFlags benchmarkFlags, projectConfigShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags, @@ -185,7 +189,8 @@ } where (localConfig, allConfig) = splitConfig (convertLegacyPerPackageFlags - configFlags installFlags haddockFlags testFlags) + configFlags installFlags + haddockFlags testFlags benchmarkFlags) -- split the package config (from command line arguments) into -- those applied to all packages and those to local only. -- @@ -231,7 +236,8 @@ savedUploadFlags = _, savedReportFlags = _, savedHaddockFlags = haddockFlags, - savedTestFlags = testFlags + savedTestFlags = testFlags, + savedBenchmarkFlags = benchmarkFlags } = mempty { projectConfigBuildOnly = configBuildOnly, @@ -241,21 +247,23 @@ where --TODO: [code cleanup] eliminate use of default*Flags here and specify the -- defaults in the various resolve functions in terms of the new types. - configExFlags' = defaultConfigExFlags <> configExFlags - installFlags' = defaultInstallFlags <> installFlags - clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags - haddockFlags' = defaultHaddockFlags <> haddockFlags - testFlags' = defaultTestFlags <> testFlags + configExFlags' = defaultConfigExFlags <> configExFlags + installFlags' = defaultInstallFlags <> installFlags + clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags + haddockFlags' = defaultHaddockFlags <> haddockFlags + testFlags' = defaultTestFlags <> testFlags + benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags configAllPackages = convertLegacyPerPackageFlags - configFlags installFlags' haddockFlags' testFlags' + configFlags installFlags' + haddockFlags' testFlags' benchmarkFlags' configShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags' installFlags' configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags installFlags' clientInstallFlags' - haddockFlags' testFlags' + haddockFlags' testFlags' benchmarkFlags' -- | Convert the project config from the legacy types to the 'ProjectConfig' @@ -274,7 +282,7 @@ clientInstallFlags, legacyAllConfig, legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags - haddockFlags testFlags, + haddockFlags testFlags benchmarkFlags, legacySpecificConfig } = @@ -292,23 +300,25 @@ projectConfigSpecificPackage = fmap perPackage legacySpecificConfig } where - configAllPackages = convertLegacyPerPackageFlags g i h t - where LegacyPackageConfig g i h t = legacyAllConfig + configAllPackages = convertLegacyPerPackageFlags g i h t b + where LegacyPackageConfig g i h t b = legacyAllConfig configLocalPackages = convertLegacyPerPackageFlags configFlags installPerPkgFlags haddockFlags - testFlags + testFlags benchmarkFlags configPackagesShared= convertLegacyAllPackageFlags globalFlags (configFlags <> configShFlags) configExFlags installSharedFlags configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configShFlags installSharedFlags clientInstallFlags - haddockFlags testFlags + haddockFlags testFlags benchmarkFlags perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags - perPkgHaddockFlags perPkgTestFlags) = + perPkgHaddockFlags perPkgTestFlags + perPkgBenchmarkFlags) = convertLegacyPerPackageFlags - perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags perPkgTestFlags + perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags + perPkgTestFlags perPkgBenchmarkFlags -- | Helper used by other conversion functions that returns the @@ -326,6 +336,7 @@ globalSandboxConfigFile = _, -- ?? globalRemoteRepos = projectConfigRemoteRepos, globalLocalRepos = projectConfigLocalRepos, + globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, globalProgPathExtra = projectConfigProgPathExtra, globalStoreDir = projectConfigStoreDir } = globalFlags @@ -363,6 +374,7 @@ --installUpgradeDeps = projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, + installFineGrainedConflicts = projectConfigFineGrainedConflicts, installMinimizeConflictSet = projectConfigMinimizeConflictSet, installPerComponent = projectConfigPerComponent, installIndependentGoals = projectConfigIndependentGoals, @@ -378,8 +390,9 @@ -- 'PackageConfig' subset of the 'ProjectConfig'. -- convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags - -> TestFlags -> PackageConfig -convertLegacyPerPackageFlags configFlags installFlags haddockFlags testFlags = + -> TestFlags -> BenchmarkFlags -> PackageConfig +convertLegacyPerPackageFlags configFlags installFlags + haddockFlags testFlags benchmarkFlags = PackageConfig{..} where ConfigFlags { @@ -454,6 +467,9 @@ testOptions = packageConfigTestTestOptions } = testFlags + BenchmarkFlags { + benchmarkOptions = packageConfigBenchmarkOptions + } = benchmarkFlags -- | Helper used by other conversion functions that returns the @@ -462,10 +478,11 @@ convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags -> InstallFlags -> ClientInstallFlags -> HaddockFlags -> TestFlags + -> BenchmarkFlags -> ProjectConfigBuildOnly convertLegacyBuildOnlyFlags globalFlags configFlags installFlags clientInstallFlags - haddockFlags _ = + haddockFlags _ _ = ProjectConfigBuildOnly{..} where projectConfigClientInstallFlags = clientInstallFlags @@ -555,6 +572,7 @@ globalRemoteRepos = projectConfigRemoteRepos, globalCacheDir = projectConfigCacheDir, globalLocalRepos = projectConfigLocalRepos, + globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, globalLogsDir = projectConfigLogsDir, globalWorldFile = mempty, globalRequireSandbox = mempty, @@ -594,6 +612,7 @@ installUpgradeDeps = mempty, --projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts, + installFineGrainedConflicts = projectConfigFineGrainedConflicts, installMinimizeConflictSet = projectConfigMinimizeConflictSet, installIndependentGoals = projectConfigIndependentGoals, installShadowPkgs = mempty, --projectConfigShadowPkgs, @@ -630,7 +649,8 @@ legacyConfigureFlags = configFlags, legacyInstallPkgFlags= mempty, legacyHaddockFlags = haddockFlags, - legacyTestFlags = mempty + legacyTestFlags = mempty, + legacyBenchmarkFlags = mempty } where configFlags = ConfigFlags { @@ -701,7 +721,8 @@ legacyConfigureFlags = configFlags, legacyInstallPkgFlags = installFlags, legacyHaddockFlags = haddockFlags, - legacyTestFlags = testFlags + legacyTestFlags = testFlags, + legacyBenchmarkFlags = benchmarkFlags } where configFlags = ConfigFlags { @@ -802,6 +823,11 @@ testOptions = packageConfigTestTestOptions } + benchmarkFlags = BenchmarkFlags { + benchmarkDistPref = mempty, + benchmarkVerbosity = mempty, + benchmarkOptions = packageConfigBenchmarkOptions + } ------------------------------------------------ -- Parsing and showing the project config file @@ -811,6 +837,7 @@ parseLegacyProjectConfig = parseConfig legacyProjectConfigFieldDescrs legacyPackageConfigSectionDescrs + legacyPackageConfigFGSectionDescrs mempty showLegacyProjectConfig :: LegacyProjectConfig -> String @@ -818,6 +845,7 @@ Disp.render $ showConfig legacyProjectConfigFieldDescrs legacyPackageConfigSectionDescrs + legacyPackageConfigFGSectionDescrs config $+$ Disp.text "" @@ -978,8 +1006,9 @@ , "one-shot", "jobs", "keep-going", "offline", "per-component" -- solver flags: , "max-backjumps", "reorder-goals", "count-conflicts" - , "minimize-conflict-set", "independent-goals" - , "strong-flags" , "allow-boot-library-installs", "reject-unconstrained-dependencies", "index-state" + , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals" + , "strong-flags" , "allow-boot-library-installs" + , "reject-unconstrained-dependencies", "index-state" ] . commandOptionsToFields ) (installOptions ParseArgs) @@ -1097,6 +1126,20 @@ , "fail-when-no-test-suites", "test-wrapper" ] . commandOptionsToFields ) (testOptions' ParseArgs) + ++ + ( liftFields + legacyBenchmarkFlags + (\flags conf -> conf { legacyBenchmarkFlags = flags }) + . addFields + [ newLineListField "benchmark-options" + (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ) + benchmarkOptions + (\v conf -> conf { benchmarkOptions = v }) + ] + . filterFields + [] + . commandOptionsToFields + ) (benchmarkOptions' ParseArgs) where @@ -1165,10 +1208,14 @@ | otherwise = "test-" ++ name +legacyPackageConfigFGSectionDescrs :: [FGSectionDescr LegacyProjectConfig] +legacyPackageConfigFGSectionDescrs = + [ packageRepoSectionDescr + ] + legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] legacyPackageConfigSectionDescrs = - [ packageRepoSectionDescr - , packageSpecificOptionsSectionDescr + [ packageSpecificOptionsSectionDescr , liftSection legacyLocalConfig (\flags conf -> conf { legacyLocalConfig = flags }) @@ -1186,31 +1233,19 @@ remoteRepoSectionDescr ] -packageRepoSectionDescr :: SectionDescr LegacyProjectConfig -packageRepoSectionDescr = - SectionDescr { - sectionName = "source-repository-package", - sectionFields = sourceRepoFieldDescrs, - sectionSubsections = [], - sectionGet = map (\x->("", x)) - . legacyPackagesRepo, - sectionSet = +packageRepoSectionDescr :: FGSectionDescr LegacyProjectConfig +packageRepoSectionDescr = FGSectionDescr + { fgSectionName = "source-repository-package" + , fgSectionGrammar = sourceRepositoryPackageGrammar + , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo + , fgSectionSet = \lineno unused pkgrepo projconf -> do unless (null unused) $ syntaxError lineno "the section 'source-repository-package' takes no arguments" return projconf { legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo] - }, - sectionEmpty = SourceRepo { - repoKind = RepoThis, -- hopefully unused - repoType = Nothing, - repoLocation = Nothing, - repoModule = Nothing, - repoBranch = Nothing, - repoTag = Nothing, - repoSubdir = Nothing - } - } + } + } -- | The definitions of all the fields that can appear in the @package pkgfoo@ -- and @package *@ sections of the @cabal.project@-format files. @@ -1357,43 +1392,46 @@ | otherwise = arg +-- The implementation is slight hack: we parse all as remote repository +-- but if the url schema is file+noindex, we switch to local. remoteRepoSectionDescr :: SectionDescr GlobalFlags -remoteRepoSectionDescr = - SectionDescr { - sectionName = "repository", - sectionFields = remoteRepoFields, - sectionSubsections = [], - sectionGet = map (\x->(remoteRepoName x, x)) . fromNubList - . globalRemoteRepos, - sectionSet = - \lineno reponame repo0 conf -> do - when (null reponame) $ - syntaxError lineno $ "a 'repository' section requires the " - ++ "repository name as an argument" - let repo = repo0 { remoteRepoName = reponame } - when (remoteRepoKeyThreshold repo - > length (remoteRepoRootKeys repo)) $ - warning $ "'key-threshold' for repository " - ++ show (remoteRepoName repo) - ++ " higher than number of keys" - when (not (null (remoteRepoRootKeys repo)) - && remoteRepoSecure repo /= Just True) $ - warning $ "'root-keys' for repository " - ++ show (remoteRepoName repo) - ++ " non-empty, but 'secure' not set to True." - return conf { - globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) - }, - sectionEmpty = emptyRemoteRepo "" +remoteRepoSectionDescr = SectionDescr + { sectionName = "repository" + , sectionEmpty = emptyRemoteRepo "" + , sectionFields = remoteRepoFields + , sectionSubsections = [] + , sectionGet = getS + , sectionSet = setS } + where + getS :: GlobalFlags -> [(String, RemoteRepo)] + getS gf = + map (\x->(remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf)) + ++ + map (\x->(localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) + setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags + setS lineno reponame repo0 conf = do + repo1 <- postProcessRepo lineno reponame repo0 + case repo1 of + Left repo -> return conf + { globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf) + } + Right repo -> return conf + { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf) + } + localToRemote :: LocalRepo -> RemoteRepo + localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name) + { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "") + } + ------------------------------- -- Local field utils -- -- | Parser combinator for simple fields which uses the field type's --- 'Monoid' instance for combining multiple occurences of the field. +-- 'Monoid' instance for combining multiple occurrences of the field. monoidField :: Monoid a => String -> (a -> Doc) -> ReadP a a -> (b -> a) -> (a -> b -> b) -> FieldDescr b monoidField name showF readF get' set = 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 @@ -20,8 +20,11 @@ MapMappend(..), ) where +import Distribution.Client.Compat.Prelude +import Prelude () + import Distribution.Client.Types - ( RemoteRepo, AllowNewer(..), AllowOlder(..) + ( RemoteRepo, LocalRepo, AllowNewer(..), AllowOlder(..) , WriteGhcEnvironmentFilesPolicy ) import Distribution.Client.Dependency.Types ( PreSolver ) @@ -29,6 +32,7 @@ ( UserConstraint ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) +import Distribution.Client.SourceRepo (SourceRepoList) import Distribution.Client.IndexUtils.Timestamp ( IndexState ) @@ -48,7 +52,7 @@ import Distribution.System ( Platform ) import Distribution.PackageDescription - ( FlagAssignment, SourceRepo(..) ) + ( FlagAssignment ) import Distribution.Simple.Compiler ( Compiler, CompilerFlavor , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) ) @@ -61,15 +65,8 @@ import Distribution.Verbosity ( Verbosity ) -import Data.Map (Map) import qualified Data.Map as Map -import Data.Set (Set) -import Distribution.Compat.Binary (Binary) -import Distribution.Compat.Semigroup -import GHC.Generics (Generic) -import Data.Typeable - ------------------------------- -- Project config types -- @@ -107,7 +104,7 @@ projectPackagesOptional :: [String], -- | Packages in this project from remote source repositories. - projectPackagesRepo :: [SourceRepo], + projectPackagesRepo :: [SourceRepoList], -- | Packages in this project from hackage repositories. projectPackagesNamed :: [PackageVersionConstraint], @@ -182,6 +179,7 @@ -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. projectConfigLocalRepos :: NubList FilePath, + projectConfigLocalNoIndexRepos :: NubList LocalRepo, projectConfigIndexState :: Flag IndexState, projectConfigStoreDir :: Flag FilePath, @@ -197,6 +195,7 @@ projectConfigMaxBackjumps :: Flag Int, projectConfigReorderGoals :: Flag ReorderGoals, projectConfigCountConflicts :: Flag CountConflicts, + projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts, projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, projectConfigStrongFlags :: Flag StrongFlags, projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls, @@ -293,7 +292,9 @@ packageConfigTestKeepTix :: Flag Bool, packageConfigTestWrapper :: Flag FilePath, packageConfigTestFailWhenNoTestSuites :: Flag Bool, - packageConfigTestTestOptions :: [PathTemplate] + packageConfigTestTestOptions :: [PathTemplate], + -- Benchmark options + packageConfigBenchmarkOptions :: [PathTemplate] } deriving (Eq, Show, Generic) @@ -303,12 +304,19 @@ instance Binary ProjectConfigProvenance instance Binary PackageConfig +instance Structured ProjectConfig +instance Structured ProjectConfigBuildOnly +instance Structured ProjectConfigShared +instance Structured ProjectConfigProvenance +instance Structured PackageConfig -- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes -- the last value rather than the first value for overlapping keys. newtype MapLast k v = MapLast { getMapLast :: Map k v } deriving (Eq, Show, Functor, Generic, Binary, Typeable) +instance (Structured k, Structured v) => Structured (MapLast k v) + instance Ord k => Monoid (MapLast k v) where mempty = MapLast Map.empty mappend = (<>) @@ -323,6 +331,8 @@ newtype MapMappend k v = MapMappend { getMapMappend :: Map k v } deriving (Eq, Show, Functor, Generic, Binary, Typeable) +instance (Structured k, Structured v) => Structured (MapMappend k v) + instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where mempty = MapMappend Map.empty mappend = (<>) @@ -379,6 +389,7 @@ = SolverSettings { solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. solverSettingLocalRepos :: [FilePath], + solverSettingLocalNoIndexRepos :: [LocalRepo], solverSettingConstraints :: [(UserConstraint, ConstraintSource)], solverSettingPreferences :: [PackageVersionConstraint], solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages @@ -390,6 +401,7 @@ solverSettingMaxBackjumps :: Maybe Int, solverSettingReorderGoals :: ReorderGoals, solverSettingCountConflicts :: CountConflicts, + solverSettingFineGrainedConflicts :: FineGrainedConflicts, solverSettingMinimizeConflictSet :: MinimizeConflictSet, solverSettingStrongFlags :: StrongFlags, solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, @@ -407,6 +419,7 @@ deriving (Eq, Show, Generic, Typeable) instance Binary SolverSettings +instance Structured SolverSettings -- | Resolved configuration for things that affect how we build and not the @@ -437,6 +450,7 @@ buildSettingKeepTempFiles :: Bool, buildSettingRemoteRepos :: [RemoteRepo], buildSettingLocalRepos :: [FilePath], + buildSettingLocalNoIndexRepos :: [LocalRepo], buildSettingCacheDir :: FilePath, buildSettingHttpTransport :: Maybe String, buildSettingIgnoreExpiry :: Bool, diff --git a/Distribution/Client/ProjectOrchestration.hs b/Distribution/Client/ProjectOrchestration.hs --- a/Distribution/Client/ProjectOrchestration.hs +++ b/Distribution/Client/ProjectOrchestration.hs @@ -159,6 +159,7 @@ , OptimisationLevel(..)) import qualified Data.Monoid as Mon +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Map as Map import Data.Either @@ -221,6 +222,10 @@ verbosity cabalDirLayout projectConfig + -- https://github.com/haskell/cabal/issues/6013 + when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $ + warn verbosity "There are no packages or optional-packages in the project" + return ProjectBaseContext { distDirLayout, cabalDirLayout, @@ -512,6 +517,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem installPlan mPkgDb = fmap mkTargetsMap + . either (Left . toList) Right . checkErrors . map (\ts -> (,) ts <$> checkTarget ts) where @@ -609,12 +615,12 @@ -> [AvailableTarget k] -> Either err [k] selectComponentTargets subtarget = - either (Left . head) Right + either (Left . NE.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) + checkErrors :: [Either e a] -> Either (NonEmpty e) [a] + checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') }) . partitionEithers diff --git a/Distribution/Client/ProjectPlanOutput.hs b/Distribution/Client/ProjectPlanOutput.hs --- a/Distribution/Client/ProjectPlanOutput.hs +++ b/Distribution/Client/ProjectPlanOutput.hs @@ -19,7 +19,8 @@ import Distribution.Client.ProjectBuilding.Types import Distribution.Client.DistDirLayout import Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId) -import Distribution.Client.PackageHash (showHashValue, hashValue) +import Distribution.Client.HashValue (showHashValue, hashValue) +import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J @@ -52,7 +53,6 @@ import Distribution.Client.Compat.Prelude import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as BB @@ -203,6 +203,10 @@ J.object [ "type" J..= J.String "local-repo" , "path" J..= J.String repoLocalDir ] + RepoLocalNoIndex{..} -> + J.object [ "type" J..= J.String "local-repo-no-index" + , "path" J..= J.String repoLocalDir + ] RepoRemote{..} -> J.object [ "type" J..= J.String "remote-repo" , "uri" J..= J.String (show (remoteRepoURI repoRemote)) @@ -212,15 +216,14 @@ , "uri" J..= J.String (show (remoteRepoURI repoRemote)) ] - sourceRepoToJ :: PD.SourceRepo -> J.Value - sourceRepoToJ PD.SourceRepo{..} = + sourceRepoToJ :: SourceRepoMaybe -> J.Value + sourceRepoToJ SourceRepositoryPackage{..} = J.object $ filter ((/= J.Null) . snd) $ - [ "type" J..= fmap jdisplay repoType - , "location" J..= fmap J.String repoLocation - , "module" J..= fmap J.String repoModule - , "branch" J..= fmap J.String repoBranch - , "tag" J..= fmap J.String repoTag - , "subdir" J..= fmap J.String repoSubdir + [ "type" J..= jdisplay srpType + , "location" J..= J.String srpLocation + , "branch" J..= fmap J.String srpBranch + , "tag" J..= fmap J.String srpTag + , "subdir" J..= fmap J.String srpSubdir ] dist_dir = distBuildDirectory distDirLayout diff --git a/Distribution/Client/ProjectPlanning.hs b/Distribution/Client/ProjectPlanning.hs --- a/Distribution/Client/ProjectPlanning.hs +++ b/Distribution/Client/ProjectPlanning.hs @@ -70,6 +70,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Client.HashValue import Distribution.Client.ProjectPlanning.Types as Ty import Distribution.Client.PackageHash import Distribution.Client.RebuildMonad @@ -160,13 +161,13 @@ import Text.PrettyPrint hiding ((<>)) import qualified Text.PrettyPrint as Disp import qualified Data.Map as Map -import Data.Set (Set) import qualified Data.Set as Set import Control.Monad import qualified Data.Traversable as T import Control.Monad.State as State import Control.Exception import Data.List (groupBy) +import qualified Data.List.NonEmpty as NE import Data.Either import Data.Function import System.FilePath @@ -650,7 +651,12 @@ projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage) - let instantiatedPlan = instantiateInstallPlan elaboratedPlan + let instantiatedPlan + = instantiateInstallPlan + cabalStoreDirLayout + defaultInstallDirs + elaboratedShared + elaboratedPlan liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) return (instantiatedPlan, elaboratedShared) where @@ -873,8 +879,8 @@ return (pkgid, hashFromTUF hash) | pkgid <- pkgids ] | (repo, pkgids) <- - map (\grp@((_,repo):_) -> (repo, map fst grp)) - . groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) + map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp))) + . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) $ repoTarballPkgsWithMetadata ] @@ -952,6 +958,8 @@ . setCountConflicts solverSettingCountConflicts + . setFineGrainedConflicts solverSettingFineGrainedConflicts + . setMinimizeConflictSet solverSettingMinimizeConflictSet --TODO: [required eventually] should only be configurable for @@ -1077,6 +1085,7 @@ -- respective major Cabal version bundled with the respective GHC -- release). -- + -- GHC 8.8 needs Cabal >= 3.0 -- GHC 8.6 needs Cabal >= 2.4 -- GHC 8.4 needs Cabal >= 2.2 -- GHC 8.2 needs Cabal >= 2.0 @@ -1089,11 +1098,9 @@ -- TODO: long-term, this compatibility matrix should be -- stored as a field inside 'Distribution.Compiler.Compiler' setupMinCabalVersionConstraint - | isGHC, compVer >= mkVersion [8,6,1] = mkVersion [2,4] - -- GHC 8.6alpha2 (GHC 8.6.0.20180714) still shipped with a - -- devel snapshot of Cabal-2.3.0.0; the rule below can be - -- dropped at some point - | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,3] + | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2] + | isGHC, compVer >= mkVersion [8,8] = mkVersion [3,0] + | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,4] | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,2] | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0] | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24] @@ -1481,7 +1488,7 @@ -- 5. Construct the final ElaboratedConfiguredPackage let - elab = elab1 { + elab2 = elab1 { elabModuleShape = lc_shape lc, elabUnitId = abstractUnitId (lc_uid lc), elabComponentId = lc_cid lc, @@ -1491,9 +1498,15 @@ compOrderLibDependencies = ordNub (map (abstractUnitId . ci_id) (lc_includes lc ++ lc_sig_includes lc)) - }, - elabInstallDirs = install_dirs cid + } } + elab = elab2 { + elabInstallDirs = computeInstallDirs + storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab2 + } -- 6. Construct the updated local maps let cc_map' = extendConfiguredComponentMap cc cc_map @@ -1548,31 +1561,6 @@ | PkgconfigDependency pn _ <- PD.pkgconfigDepends (Cabal.componentBuildInfo comp) ] - install_dirs cid - | shouldBuildInplaceOnly spkg - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - pkgid - (newSimpleUnitId cid) - (compilerInfo compiler) - InstallDirs.NoCopyDest - platform - defaultInstallDirs) { - - -- absoluteInstallDirs sets these as 'undefined' but we have - -- to use them as "Setup.hs configure" args - InstallDirs.libsubdir = "", - InstallDirs.libexecsubdir = "", - InstallDirs.datasubdir = "" - } - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs - storeDirLayout - (compilerId compiler) - cid - inplace_bin_dir elab = binDirectoryFor distDirLayout @@ -1634,14 +1622,20 @@ elab where elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg - elab = elab0 { + elab1 = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId, elabComponentId = pkgInstalledId, elabLinkedInstantiatedWith = Map.empty, - elabInstallDirs = install_dirs, elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, elabModuleShape = modShape } + elab = elab1 { + elabInstallDirs = + computeInstallDirs storeDirLayout + defaultInstallDirs + elaboratedSharedConfig + elab1 + } modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of Nothing -> emptyModuleShape @@ -1704,31 +1698,6 @@ -- pkgStanzasEnabled is a superset of elabStanzasRequested pkgStanzasEnabled = Map.keysSet (Map.filter (id :: Bool -> Bool) elabStanzasRequested) - install_dirs - | shouldBuildInplaceOnly pkg - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - pkgid - (newSimpleUnitId pkgInstalledId) - (compilerInfo compiler) - InstallDirs.NoCopyDest - platform - defaultInstallDirs) { - - -- absoluteInstallDirs sets these as 'undefined' but we have to - -- use them as "Setup.hs configure" args - InstallDirs.libsubdir = "", - InstallDirs.libexecsubdir = "", - InstallDirs.datasubdir = "" - } - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs - storeDirLayout - (compilerId compiler) - pkgInstalledId - elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc -> ElaboratedConfiguredPackage elaborateSolverToCommon @@ -1749,12 +1718,12 @@ elabIsCanonical = True elabPkgSourceId = pkgid - elabPkgDescription = let Right (desc, _) = - PD.finalizePD + elabPkgDescription = case PD.finalizePD flags elabEnabledSpec (const True) platform (compilerInfo compiler) - [] gdesc - in desc + [] gdesc of + Right (desc, _) -> desc + Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" elabFlagAssignment = flags elabFlagDefaults = PD.mkFlagAssignment [ (Cabal.flagName flag, Cabal.flagDefault flag) @@ -1887,6 +1856,8 @@ elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions + elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] @@ -2153,8 +2124,8 @@ getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab -instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan -instantiateInstallPlan plan = +instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan +instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = InstallPlan.new (IndependentGoals False) (Graph.fromDistinctList (Map.elems ready_map)) where @@ -2182,12 +2153,12 @@ instantiateComponent uid cid insts | Just planpkg <- Map.lookup cid cmap = case planpkg of - InstallPlan.Configured (elab@ElaboratedConfiguredPackage + InstallPlan.Configured (elab0@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) -> do deps <- mapM (substUnitId insts) (compLinkedLibDependencies comp) let getDep (Module dep_uid _) = [dep_uid] - return $ InstallPlan.Configured elab { + elab1 = elab0 { elabUnitId = uid, elabComponentId = cid, elabInstantiatedWith = insts, @@ -2198,7 +2169,14 @@ ordNub (map unDefUnitId (deps ++ concatMap getDep (Map.elems insts))) } - } + } + elab = elab1 { + elabInstallDirs = computeInstallDirs storeDirLayout + defaultInstallDirs + elaboratedShared + elab1 + } + return $ InstallPlan.Configured elab _ -> return planpkg | otherwise = error ("instantiateComponent: " ++ display cid) @@ -3256,6 +3234,38 @@ sysconfdir = prefix "etc" + +computeInstallDirs :: StoreDirLayout + -> InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> InstallDirs.InstallDirs FilePath +computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab + | elabBuildStyle elab == BuildInplaceOnly + -- use the ordinary default install dirs + = (InstallDirs.absoluteInstallDirs + (elabPkgSourceId elab) + (elabUnitId elab) + (compilerInfo (pkgConfigCompiler elaboratedShared)) + InstallDirs.NoCopyDest + (pkgConfigPlatform elaboratedShared) + defaultInstallDirs) { + + -- absoluteInstallDirs sets these as 'undefined' but we have + -- to use them as "Setup.hs configure" args + InstallDirs.libsubdir = "", + InstallDirs.libexecsubdir = "", + InstallDirs.datasubdir = "" + } + + | otherwise + -- use special simplified install dirs + = storePackageInstallDirs' + storeDirLayout + (compilerId (pkgConfigCompiler elaboratedShared)) + (elabUnitId elab) + + --TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, -- make the various Setup.hs {configure,build,copy} flags @@ -3459,10 +3469,10 @@ -> Verbosity -> FilePath -> Cabal.BenchmarkFlags -setupHsBenchFlags _ _ verbosity builddir = Cabal.BenchmarkFlags +setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags { benchmarkDistPref = toFlag builddir , benchmarkVerbosity = toFlag verbosity - , benchmarkOptions = mempty + , benchmarkOptions = elabBenchmarkOptions } setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String] 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 @@ -60,6 +60,9 @@ SetupScriptStyle(..), ) where +import Distribution.Client.Compat.Prelude +import Prelude () + import Distribution.Client.TargetSelector ( SubComponentTarget(..) ) import Distribution.Client.PackageHash @@ -102,16 +105,10 @@ import Distribution.Compat.Graph (IsNode(..)) import Distribution.Simple.Utils (ordNub) -import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (catMaybes) -import Data.Set (Set) import qualified Data.ByteString.Lazy as LBS -import Distribution.Compat.Binary -import GHC.Generics (Generic) import qualified Data.Monoid as Mon -import Data.Typeable -import Control.Monad +import Control.Monad (guard) import System.FilePath (()) @@ -158,6 +155,7 @@ --TODO: [code cleanup] no Eq instance instance Binary ElaboratedSharedConfig +instance Structured ElaboratedSharedConfig data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage { @@ -297,6 +295,8 @@ elabTestFailWhenNoTestSuites :: Bool, elabTestTestOptions :: [PathTemplate], + elabBenchmarkOptions :: [PathTemplate], + -- Setup.hs related things: -- | One of four modes for how we build and interact with the Setup.hs @@ -461,6 +461,7 @@ nodeNeighbors = elabOrderDependencies instance Binary ElaboratedConfiguredPackage +instance Structured ElaboratedConfiguredPackage data ElaboratedPackageOrComponent = ElabPackage ElaboratedPackage @@ -468,6 +469,7 @@ deriving (Eq, Show, Generic) instance Binary ElaboratedPackageOrComponent +instance Structured ElaboratedPackageOrComponent elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName elabComponentName elab = @@ -659,6 +661,7 @@ deriving (Eq, Show, Generic) instance Binary ElaboratedComponent +instance Structured ElaboratedComponent -- | See 'elabOrderDependencies'. compOrderDependencies :: ElaboratedComponent -> [UnitId] @@ -707,6 +710,7 @@ deriving (Eq, Show, Generic) instance Binary ElaboratedPackage +instance Structured ElaboratedPackage -- | See 'elabOrderDependencies'. This gives the unflattened version, -- which can be useful in some circumstances. @@ -738,6 +742,7 @@ deriving (Eq, Show, Generic) instance Binary BuildStyle +instance Structured BuildStyle type CabalFileText = LBS.ByteString @@ -755,6 +760,7 @@ deriving (Eq, Ord, Show, Generic) instance Binary ComponentTarget +instance Structured ComponentTarget -- | Unambiguously render a 'ComponentTarget', e.g., to pass -- to a Cabal Setup script. @@ -830,3 +836,4 @@ deriving (Eq, Show, Generic, Typeable) instance Binary SetupScriptStyle +instance Structured SetupScriptStyle diff --git a/Distribution/Client/RebuildMonad.hs b/Distribution/Client/RebuildMonad.hs --- a/Distribution/Client/RebuildMonad.hs +++ b/Distribution/Client/RebuildMonad.hs @@ -116,7 +116,7 @@ -- -- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. -- -rerunIfChanged :: (Binary a, Binary b) +rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b) => Verbosity -> FileMonitor a b -> a diff --git a/Distribution/Client/Sandbox.hs b/Distribution/Client/Sandbox.hs --- a/Distribution/Client/Sandbox.hs +++ b/Distribution/Client/Sandbox.hs @@ -44,6 +44,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Utils.Generic(safeLast) import Distribution.Client.Setup ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..) @@ -91,7 +92,7 @@ import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..) - , emptyTestFlags + , emptyTestFlags, emptyBenchmarkFlags , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist ( prepareTree ) import Distribution.Simple.Utils ( die', debug, notice, info, warn @@ -216,10 +217,10 @@ tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath tryGetIndexFilePath' verbosity globalFlags = do let paths = fromNubList $ globalLocalRepos globalFlags - case paths of - [] -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ + case safeLast paths of + Nothing -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ "no local repos found. " ++ checkConfiguration - _ -> return $ (last paths) Index.defaultIndexFileName + Just lp -> return $ lp Index.defaultIndexFileName where checkConfiguration = "Please check your configuration ('" ++ userPackageEnvironmentFile ++ "')." @@ -685,7 +686,7 @@ ,comp, platform, progdb ,UseSandbox sandboxDir, Just sandboxPkgInfo ,globalFlags, configFlags, configExFlags, installFlags - ,haddockFlags, emptyTestFlags) + ,haddockFlags, emptyTestFlags, emptyBenchmarkFlags) -- This can actually be replaced by a call to 'install', but we use a -- lower-level API because of layer separation reasons. Additionally, we diff --git a/Distribution/Client/Security/HTTP.hs b/Distribution/Client/Security/HTTP.hs --- a/Distribution/Client/Security/HTTP.hs +++ b/Distribution/Client/Security/HTTP.hs @@ -35,7 +35,6 @@ import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked import Hackage.Security.Util.Pretty -import qualified Hackage.Security.Util.Lens as Lens {------------------------------------------------------------------------------- 'HttpLib' implementation @@ -142,7 +141,14 @@ finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))] insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])] - insert x y = Lens.modify (Lens.lookupM x) (++ y) + insert x y = modifyAssocList x (++ y) + + -- modify the first matching element + modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)] + modifyAssocList a f = go where + go [] = [] + go (p@(a', b) : xs) | a == a' = (a', f b) : xs + | otherwise = p : go xs {------------------------------------------------------------------------------- Custom exceptions diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -23,7 +23,7 @@ , configureExCommand, ConfigExFlags(..), defaultConfigExFlags , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , filterTestFlags - , replCommand, testCommand, benchmarkCommand, testOptions + , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions , configureExOptions, reconfigureCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , filterHaddockArgs, filterHaddockFlags, haddockOptions @@ -61,9 +61,9 @@ , liftOptions , yesNoOpt --TODO: stop exporting these: - , showRepo - , parseRepo - , readRepo + , showRemoteRepo + , parseRemoteRepo + , readRemoteRepo ) where import Prelude () @@ -73,6 +73,7 @@ import Distribution.Client.Types ( Username(..), Password(..), RemoteRepo(..) + , LocalRepo (..), emptyLocalRepo , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , WriteGhcEnvironmentFilesPolicy(..) ) @@ -101,7 +102,7 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup ( ConfigFlags(..), BuildFlags(..), ReplFlags - , TestFlags, BenchmarkFlags(..) + , TestFlags, BenchmarkFlags , SDistFlags(..), HaddockFlags(..) , CleanFlags(..), DoctestFlags(..) , CopyFlags(..), RegisterFlags(..) @@ -420,8 +421,13 @@ option [] ["remote-repo"] "The name and url for a remote repository" globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) - (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList)) + (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) + ,option [] ["local-no-index-repo"] + "The name and a path for a local no-index repository" + globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v }) + (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList)) + ,option [] ["remote-repo-cache"] "The location where downloads from all remote repos are cached" globalCacheDir (\v flags -> flags { globalCacheDir = v }) @@ -997,6 +1003,7 @@ fetchMaxBackjumps :: Flag Int, fetchReorderGoals :: Flag ReorderGoals, fetchCountConflicts :: Flag CountConflicts, + fetchFineGrainedConflicts :: Flag FineGrainedConflicts, fetchMinimizeConflictSet :: Flag MinimizeConflictSet, fetchIndependentGoals :: Flag IndependentGoals, fetchShadowPkgs :: Flag ShadowPkgs, @@ -1017,6 +1024,7 @@ fetchMaxBackjumps = Flag defaultMaxBackjumps, fetchReorderGoals = Flag (ReorderGoals False), fetchCountConflicts = Flag (CountConflicts True), + fetchFineGrainedConflicts = Flag (FineGrainedConflicts True), fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), fetchIndependentGoals = Flag (IndependentGoals False), fetchShadowPkgs = Flag (ShadowPkgs False), @@ -1079,6 +1087,7 @@ fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v }) + fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v }) fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) @@ -1100,6 +1109,7 @@ freezeMaxBackjumps :: Flag Int, freezeReorderGoals :: Flag ReorderGoals, freezeCountConflicts :: Flag CountConflicts, + freezeFineGrainedConflicts :: Flag FineGrainedConflicts, freezeMinimizeConflictSet :: Flag MinimizeConflictSet, freezeIndependentGoals :: Flag IndependentGoals, freezeShadowPkgs :: Flag ShadowPkgs, @@ -1118,6 +1128,7 @@ freezeMaxBackjumps = Flag defaultMaxBackjumps, freezeReorderGoals = Flag (ReorderGoals False), freezeCountConflicts = Flag (CountConflicts True), + freezeFineGrainedConflicts = Flag (FineGrainedConflicts True), freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), freezeIndependentGoals = Flag (IndependentGoals False), freezeShadowPkgs = Flag (ShadowPkgs False), @@ -1171,6 +1182,7 @@ freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v }) + freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v }) freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) @@ -1367,13 +1379,15 @@ -- * Other commands -- ------------------------------------------------------------ -upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +upgradeCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) upgradeCommand = configureCommand { commandName = "upgrade", commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, commandUsage = usageFlagsOrPackages "upgrade", - commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty), + commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), commandOptions = commandOptions installCommand } @@ -1741,6 +1755,7 @@ installMaxBackjumps :: Flag Int, installReorderGoals :: Flag ReorderGoals, installCountConflicts :: Flag CountConflicts, + installFineGrainedConflicts :: Flag FineGrainedConflicts, installMinimizeConflictSet :: Flag MinimizeConflictSet, installIndependentGoals :: Flag IndependentGoals, installShadowPkgs :: Flag ShadowPkgs, @@ -1790,6 +1805,7 @@ installMaxBackjumps = Flag defaultMaxBackjumps, installReorderGoals = Flag (ReorderGoals False), installCountConflicts = Flag (CountConflicts True), + installFineGrainedConflicts = Flag (FineGrainedConflicts True), installMinimizeConflictSet = Flag (MinimizeConflictSet False), installIndependentGoals= Flag (IndependentGoals False), installShadowPkgs = Flag (ShadowPkgs False), @@ -1830,7 +1846,9 @@ allSolvers :: String allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver])) -installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags + ) installCommand = CommandUI { commandName = "install", commandSynopsis = "Install packages.", @@ -1883,7 +1901,7 @@ ++ " " ++ (map (const ' ') pname) ++ " " ++ " Change installation destination\n", - commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty), + commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), commandOptions = \showOrParseArgs -> liftOptions get1 set1 -- Note: [Hidden Flags] @@ -1902,13 +1920,15 @@ installOptions showOrParseArgs) ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) ++ liftOptions get5 set5 (testOptions showOrParseArgs) + ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) } where - get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e) - get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e) - get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e) - get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e) - get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e) + get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f) + get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f) + get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f) + get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f) + get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f) + get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) haddockCommand :: CommandUI HaddockFlags haddockCommand = Cabal.haddockCommand @@ -1968,6 +1988,19 @@ prefixTest name | "test-" `isPrefixOf` name = name | otherwise = "test-" ++ name +benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags] +benchmarkOptions showOrParseArgs + = [ opt { optionName = prefixBenchmark name, + optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr + | descr <- optionDescr opt] } + | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs + , let name = optionName opt + , name `elem` ["benchmark-options", "benchmark-option"] + ] + where + prefixBenchmark name | "benchmark-" `isPrefixOf` name = name + | otherwise = "benchmark-" ++ name + fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w @@ -2003,6 +2036,7 @@ installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) installReorderGoals (\v flags -> flags { installReorderGoals = v }) installCountConflicts (\v flags -> flags { installCountConflicts = v }) + installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v }) installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) @@ -2835,6 +2869,7 @@ -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags) + -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags) -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) @@ -2843,8 +2878,8 @@ -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) -> [OptionField flags] optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc - getmc setmc getig setig getsip setsip getstrfl setstrfl - getib setib getoc setoc = + getfgc setfgc getmc setmc getig setig getsip setsip + getstrfl setstrfl getib setib getoc setoc = [ 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.") getmbj setmbj @@ -2860,6 +2895,11 @@ (fmap asBool . getcc) (setcc . fmap CountConflicts) (yesNoOpt showOrParseArgs) + , option [] ["fine-grained-conflicts"] + "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)." + (fmap asBool . getfgc) + (setfgc . fmap FineGrainedConflicts) + (yesNoOpt showOrParseArgs) , option [] ["minimize-conflict-set"] ("When there is no solution, try to improve the error message by finding " ++ "a minimal conflict set (default: false). May increase run time " @@ -2932,15 +2972,15 @@ v | v == nullVersion -> Dependency (packageName p) anyVersion (Set.singleton LMainLibName) | otherwise -> Dependency (packageName p) (thisVersion v) (Set.singleton LMainLibName) -showRepo :: RemoteRepo -> String -showRepo repo = remoteRepoName repo ++ ":" +showRemoteRepo :: RemoteRepo -> String +showRemoteRepo repo = remoteRepoName repo ++ ":" ++ uriToString id (remoteRepoURI repo) [] -readRepo :: String -> Maybe RemoteRepo -readRepo = readPToMaybe parseRepo +readRemoteRepo :: String -> Maybe RemoteRepo +readRemoteRepo = readPToMaybe parseRemoteRepo -parseRepo :: Parse.ReadP r RemoteRepo -parseRepo = do +parseRemoteRepo :: Parse.ReadP r RemoteRepo +parseRemoteRepo = do name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") _ <- Parse.char ':' uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") @@ -2953,6 +2993,21 @@ remoteRepoKeyThreshold = 0, remoteRepoShouldTryHttps = False } + +showLocalRepo :: LocalRepo -> String +showLocalRepo repo = localRepoName repo ++ ":" ++ localRepoPath repo + +readLocalRepo :: String -> Maybe LocalRepo +readLocalRepo = readPToMaybe parseLocalRepo + +parseLocalRepo :: Parse.ReadP r LocalRepo +parseLocalRepo = do + name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") + _ <- Parse.char ':' + path <- Parse.munch1 (const True) + return $ (emptyLocalRepo name) + { localRepoPath = path + } -- ------------------------------------------------------------ -- * Helpers for Documentation diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -81,6 +81,8 @@ ( Lock, criticalSection ) import Distribution.Simple.Setup ( Flag(..) ) +import Distribution.Utils.Generic + ( safeHead ) import Distribution.Simple.Utils ( die', debug, info, infoNoWrap , cabalVersion, tryFindPackageDesc, comparing @@ -726,7 +728,8 @@ ++ "' requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed." - pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs + pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs + err = error "Distribution.Client.installedCabalVersion: empty version list" in return (packageVersion ipkginfo ,Just . IPI.installedComponentId $ ipkginfo, options'') diff --git a/Distribution/Client/SolverInstallPlan.hs b/Distribution/Client/SolverInstallPlan.hs --- a/Distribution/Client/SolverInstallPlan.hs +++ b/Distribution/Client/SolverInstallPlan.hs @@ -51,6 +51,9 @@ reverseTopologicalOrder, ) where +import Distribution.Client.Compat.Prelude hiding (toList) +import Prelude () + import Distribution.Package ( PackageIdentifier(..), Package(..), PackageName , HasUnitId(..), PackageId, packageVersion, packageName ) @@ -67,18 +70,12 @@ import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SolverId -import Data.List - ( intercalate ) -import Data.Maybe - ( fromMaybe, mapMaybe ) -import Distribution.Compat.Binary (Binary(..)) import Distribution.Compat.Graph (Graph, IsNode(..)) +import qualified Data.Foldable as Foldable import qualified Data.Graph as OldGraph import qualified Distribution.Compat.Graph as Graph import qualified Data.Map as Map -import Data.Map (Map) import Data.Array ((!)) -import Data.Typeable type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc @@ -88,7 +85,7 @@ planIndex :: !SolverPlanIndex, planIndepGoals :: !IndependentGoals } - deriving (Typeable) + deriving (Typeable, Generic) {- -- | Much like 'planPkgIdOf', but mapping back to full packages. @@ -102,24 +99,10 @@ Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed" -} -mkInstallPlan :: SolverPlanIndex - -> IndependentGoals - -> SolverInstallPlan -mkInstallPlan index indepGoals = - SolverInstallPlan { - planIndex = index, - planIndepGoals = indepGoals - } -instance Binary SolverInstallPlan where - put SolverInstallPlan { - planIndex = index, - planIndepGoals = indepGoals - } = put (index, indepGoals) - get = do - (index, indepGoals) <- get - return $! mkInstallPlan index indepGoals +instance Binary SolverInstallPlan +instance Structured SolverInstallPlan showPlanIndex :: [SolverPlanPackage] -> String showPlanIndex = intercalate "\n" . map showPlanPackage @@ -140,11 +123,11 @@ -> Either [SolverPlanProblem] SolverInstallPlan new indepGoals index = case problems indepGoals index of - [] -> Right (mkInstallPlan index indepGoals) + [] -> Right (SolverInstallPlan index indepGoals) probs -> Left probs toList :: SolverInstallPlan -> [SolverPlanPackage] -toList = Graph.toList . planIndex +toList = Foldable.toList . planIndex toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage toMap = Graph.toMap . planIndex @@ -239,7 +222,7 @@ dependencyInconsistencies indepGoals index ] ++ [ PackageStateInvalid pkg pkg' - | pkg <- Graph.toList index + | pkg <- Foldable.toList index , Just pkg' <- map (flip Graph.lookup index) (nodeNeighbors pkg) , not (stateDependencyRelation pkg pkg') ] @@ -316,7 +299,7 @@ setupRoots :: SolverPlanIndex -> [[SolverId]] setupRoots = filter (not . null) . map (CD.setupDeps . resolverPackageLibDeps) - . Graph.toList + . Foldable.toList -- | Given a package index where we assume we want to use all the packages -- (use 'dependencyClosure' if you need to get such a index subset) find out @@ -345,7 +328,7 @@ inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) | -- For each package @pkg@ - pkg <- Graph.toList index + pkg <- Foldable.toList index -- Find out which @sid@ @pkg@ depends on , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) diff --git a/Distribution/Client/SourceRepo.hs b/Distribution/Client/SourceRepo.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/SourceRepo.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Distribution.Client.SourceRepo where + +import Distribution.Client.Compat.Prelude +import Prelude () +import Distribution.Compat.Lens (Lens, Lens') + +import Distribution.Types.SourceRepo + ( RepoType(..)) +import Distribution.FieldGrammar (FieldGrammar, ParsecFieldGrammar', PrettyFieldGrammar', uniqueField, uniqueFieldAla, optionalFieldAla, monoidalFieldAla) +import Distribution.Parsec.Newtypes (Token (..), FilePathNT (..), alaList', NoCommaFSep (..)) + +-- | @source-repository-package@ definition +-- +data SourceRepositoryPackage f = SourceRepositoryPackage + { srpType :: !RepoType + , srpLocation :: !String + , srpTag :: !(Maybe String) + , srpBranch :: !(Maybe String) + , srpSubdir :: !(f FilePath) + } + deriving (Generic) + +deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f) +deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f) +deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f) +deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f) +deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f) + +-- | Read from @cabal.project@ +type SourceRepoList = SourceRepositoryPackage [] + +-- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo' +type SourceRepoMaybe = SourceRepositoryPackage Maybe + +-- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory. +type SourceRepoProxy = SourceRepositoryPackage Proxy + +srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g +srpHoist nt s = s { srpSubdir = nt (srpSubdir s) } + +srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy +srpToProxy s = s { srpSubdir = Proxy } + +-- | Split single @source-repository-package@ declaration with multiple subdirs, +-- into multiple ones with at most single subdir. +srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe) +srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } = + s { srpSubdir = Nothing } :| [] +srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where + f subdir = s { srpSubdir = Just subdir } + +------------------------------------------------------------------------------- +-- Lens +------------------------------------------------------------------------------- + +srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType +srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s)) +{-# INLINE srpTypeLens #-} + +srpLocationLens :: Lens' (SourceRepositoryPackage f) String +srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s)) +{-# INLINE srpLocationLens #-} + +srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String) +srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s)) +{-# INLINE srpTagLens #-} + +srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String) +srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s)) +{-# INLINE srpBranchLens #-} + +srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath) +srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s)) +{-# INLINE srpSubdirLens #-} + +------------------------------------------------------------------------------- +-- Parser & PPrinter +------------------------------------------------------------------------------- + +sourceRepositoryPackageGrammar + :: (FieldGrammar g, Applicative (g SourceRepoList)) + => g SourceRepoList SourceRepoList +sourceRepositoryPackageGrammar = SourceRepositoryPackage + <$> uniqueField "type" srpTypeLens + <*> uniqueFieldAla "location" Token srpLocationLens + <*> optionalFieldAla "tag" Token srpTagLens + <*> optionalFieldAla "branch" Token srpBranchLens + <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there... +{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-} +{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-} diff --git a/Distribution/Client/SourceRepoParse.hs b/Distribution/Client/SourceRepoParse.hs deleted file mode 100644 --- a/Distribution/Client/SourceRepoParse.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Distribution.Client.SourceRepoParse where - -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Deprecated.ParseUtils (FieldDescr (..), syntaxError) -import Distribution.FieldGrammar.FieldDescrs (fieldDescrsToList) -import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar) -import Distribution.Parsec (explicitEitherParsec) -import Distribution.Simple.Utils (fromUTF8BS) -import Distribution.Types.SourceRepo (RepoKind (..), SourceRepo) - -sourceRepoFieldDescrs :: [FieldDescr SourceRepo] -sourceRepoFieldDescrs = - map toDescr . fieldDescrsToList $ sourceRepoFieldGrammar (RepoKindUnknown "unused") - where - toDescr (name, pretty, parse) = FieldDescr - { fieldName = fromUTF8BS name - , fieldGet = pretty - , fieldSet = \lineNo str x -> - either (syntaxError lineNo) return - $ explicitEitherParsec (parse x) str - } diff --git a/Distribution/Client/Store.hs b/Distribution/Client/Store.hs --- a/Distribution/Client/Store.hs +++ b/Distribution/Client/Store.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-} -- | Management for the installed package store. @@ -23,7 +23,6 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Client.Compat.FileLock import Distribution.Client.DistDirLayout import Distribution.Client.RebuildMonad @@ -36,14 +35,21 @@ import Distribution.Verbosity import Distribution.Deprecated.Text -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 +#ifdef MIN_VERSION_lukko +import Lukko +#else +import System.IO (openFile, IOMode(ReadWriteMode), hClose) +import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock)) +#if MIN_VERSION_base(4,11,0) +import GHC.IO.Handle.Lock (hUnlock) +#endif +#endif -- $concurrency -- @@ -236,6 +242,26 @@ compid unitid action = bracket takeLock releaseLock (\_hnd -> action) where +#ifdef MIN_VERSION_lukko + takeLock + | fileLockingSupported = do + fd <- fdOpen (storeIncomingLock compid unitid) + gotLock <- fdTryLock fd ExclusiveLock + unless gotLock $ do + info verbosity $ "Waiting for file lock on store entry " + ++ display compid display unitid + fdLock fd ExclusiveLock + return fd + + -- if there's no locking, do nothing. Be careful on AIX. + | otherwise = return undefined -- :( + + releaseLock fd + | fileLockingSupported = do + fdUnlock fd + fdClose fd + | otherwise = return () +#else takeLock = do h <- openFile (storeIncomingLock compid unitid) ReadWriteMode -- First try non-blocking, but if we would have to wait then @@ -247,5 +273,5 @@ hLock h ExclusiveLock return h - releaseLock = hClose - + releaseLock h = hUnlock h >> hClose h +#endif diff --git a/Distribution/Client/TargetSelector.hs b/Distribution/Client/TargetSelector.hs --- a/Distribution/Client/TargetSelector.hs +++ b/Distribution/Client/TargetSelector.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, RecordWildCards, NamedFieldPuns #-} +-- TODO +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.TargetSelector @@ -78,6 +80,7 @@ ( on ) import Data.List ( stripPrefix, partition, groupBy ) +import qualified Data.List.NonEmpty as NE import Data.Ord ( comparing ) import qualified Data.Map.Lazy as Map.Lazy @@ -191,6 +194,7 @@ deriving (Eq, Ord, Show, Generic) instance Binary SubComponentTarget +instance Structured SubComponentTarget -- ------------------------------------------------------------ @@ -502,9 +506,9 @@ projectIsEmpty = null knownPackagesAll classifyMatchErrors errs - | not (null expected) - = let (things, got:_) = unzip expected in - TargetSelectorExpected targetStr things got + | Just expectedNE <- NE.nonEmpty expected + = let (things, got:|_) = NE.unzip expectedNE in + TargetSelectorExpected targetStr (NE.toList things) got | not (null nosuch) = TargetSelectorNoSuch targetStr nosuch diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -669,6 +669,7 @@ deriving (Eq, Show, Generic) instance Binary UserQualifier +instance Structured UserQualifier -- | Version of 'ConstraintScope' that a user may specify on the -- command line. @@ -684,6 +685,7 @@ deriving (Eq, Show, Generic) instance Binary UserConstraintScope +instance Structured UserConstraintScope fromUserQualifier :: UserQualifier -> Qualifier fromUserQualifier UserQualToplevel = QualToplevel @@ -703,6 +705,7 @@ deriving (Eq, Show, Generic) instance Binary UserConstraint +instance Structured UserConstraint userConstraintPackageName :: UserConstraint -> PackageName userConstraintPackageName (UserConstraint scope _) = scopePN scope diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -4,7 +4,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Types @@ -48,8 +47,9 @@ ( ComponentName(..) ) import Distribution.Types.LibraryName ( LibraryName(..) ) -import Distribution.Types.SourceRepo - ( SourceRepo ) +import Distribution.Client.SourceRepo + ( SourceRepoMaybe ) +import Distribution.Client.HashValue (showHashValue, hashValue, truncateHash) import Distribution.Solver.Types.PackageIndex ( PackageIndex ) @@ -65,13 +65,14 @@ import Distribution.Compat.Graph (IsNode(..)) import qualified Distribution.Deprecated.ReadP as Parse import Distribution.Deprecated.ParseUtils (parseOptCommaList) -import Distribution.Simple.Utils (ordNub) +import Distribution.Simple.Utils (ordNub, toUTF8BS) import Distribution.Deprecated.Text (Text(..)) -import Network.URI (URI(..), URIAuth(..), nullURI) -import Control.Exception - ( Exception, SomeException ) +import Network.URI (URI(..), nullURI) +import Control.Exception (Exception, SomeException) + import qualified Text.PrettyPrint as Disp +import qualified Data.ByteString.Lazy.Char8 as LBS newtype Username = Username { unUsername :: String } @@ -172,6 +173,7 @@ } instance Binary ConfiguredId +instance Structured ConfiguredId instance Show ConfiguredId where show cid = show (confInstId cid) @@ -241,6 +243,7 @@ deriving (Eq, Show, Functor, Generic) instance Binary pkg => Binary (PackageSpecifier pkg) +instance Structured pkg => Structured (PackageSpecifier pkg) pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName pkgSpecifierTarget (NamedPackage name _) = name @@ -287,21 +290,11 @@ | RepoTarballPackage Repo PackageId local -- | A package available from a version control system source repository - | RemoteSourceRepoPackage SourceRepo local + | RemoteSourceRepoPackage SourceRepoMaybe local deriving (Show, Functor, Eq, Ord, Generic, Typeable) instance Binary local => Binary (PackageLocation local) - --- note, network-uri-2.6.0.3+ provide a Generic instance but earlier --- versions do not, so we use manual Binary instances here -instance Binary URI where - put (URI a b c d e) = do put a; put b; put c; put d; put e - get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get - return (URI a b c d e) - -instance Binary URIAuth where - put (URIAuth a b c) = do put a; put b; put c - get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c) +instance Structured local => Structured (PackageLocation local) data RemoteRepo = RemoteRepo { @@ -334,11 +327,40 @@ deriving (Show, Eq, Ord, Generic) instance Binary RemoteRepo +instance Structured RemoteRepo -- | Construct a partial 'RemoteRepo' value to fold the field parser list over. emptyRemoteRepo :: String -> RemoteRepo emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False +-- | /no-index/ style local repositories. +-- +-- https://github.com/haskell/cabal/issues/6359 +data LocalRepo = LocalRepo + { localRepoName :: String + , localRepoPath :: FilePath + , localRepoSharedCache :: Bool + } + deriving (Show, Eq, Ord, Generic) + +instance Binary LocalRepo +instance Structured LocalRepo + +-- | Construct a partial 'LocalRepo' value to fold the field parser list over. +emptyLocalRepo :: String -> LocalRepo +emptyLocalRepo name = LocalRepo name "" False + +-- | Calculate a cache key for local-repo. +-- +-- For remote repositories we just use name, but local repositories may +-- all be named "local", so we add a bit of `localRepoPath` into the +-- mix. +localRepoCacheKey :: LocalRepo -> String +localRepoCacheKey local = localRepoName local ++ "-" ++ hashPart where + hashPart + = showHashValue $ truncateHash 8 $ hashValue + $ LBS.fromStrict $ toUTF8BS $ localRepoPath local + -- | Different kinds of repositories -- -- NOTE: It is important that this type remains serializable. @@ -347,6 +369,14 @@ RepoLocal { repoLocalDir :: FilePath } + + -- | Local repository, without index. + -- + -- https://github.com/haskell/cabal/issues/6359 + | RepoLocalNoIndex + { repoLocal :: LocalRepo + , repoLocalDir :: FilePath + } -- | Standard (unsecured) remote repositores | RepoRemote { @@ -369,17 +399,20 @@ deriving (Show, Eq, Ord, Generic) instance Binary Repo +instance Structured Repo -- | Check if this is a remote repo isRepoRemote :: Repo -> Bool -isRepoRemote RepoLocal{} = False -isRepoRemote _ = True +isRepoRemote RepoLocal{} = False +isRepoRemote RepoLocalNoIndex{} = False +isRepoRemote _ = True -- | Extract @RemoteRepo@ from @Repo@ if remote. maybeRepoRemote :: Repo -> Maybe RemoteRepo -maybeRepoRemote (RepoLocal _localDir) = Nothing -maybeRepoRemote (RepoRemote r _localDir) = Just r -maybeRepoRemote (RepoSecure r _localDir) = Just r +maybeRepoRemote (RepoLocal _localDir) = Nothing +maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing +maybeRepoRemote (RepoRemote r _localDir) = Just r +maybeRepoRemote (RepoSecure r _localDir) = Just r -- ------------------------------------------------------------ -- * Build results @@ -423,11 +456,10 @@ instance Binary DocsResult instance Binary TestsResult ---FIXME: this is a total cheat -instance Binary SomeException where - put _ = return () - get = fail "cannot serialise exceptions" - +instance Structured BuildFailure +instance Structured BuildResult +instance Structured DocsResult +instance Structured TestsResult -- ------------------------------------------------------------ -- * --allow-newer/--allow-older @@ -554,6 +586,14 @@ instance Binary AllowNewer instance Binary AllowOlder +instance Structured RelaxDeps +instance Structured RelaxDepMod +instance Structured RelaxDepScope +instance Structured RelaxDepSubject +instance Structured RelaxedDep +instance Structured AllowNewer +instance Structured AllowOlder + -- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations -- -- Equivalent to @isRelaxDeps = (/= 'mempty')@ @@ -607,3 +647,4 @@ deriving (Eq, Enum, Bounded, Generic, Show) instance Binary WriteGhcEnvironmentFilesPolicy +instance Structured WriteGhcEnvironmentFilesPolicy diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -74,6 +74,7 @@ transport <- repoContextGetTransport repoCtxt case repo of RepoLocal{..} -> return () + RepoLocalNoIndex{..} -> return () RepoRemote{..} -> do downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir case downloadResult of diff --git a/Distribution/Client/Utils/Parsec.hs b/Distribution/Client/Utils/Parsec.hs --- a/Distribution/Client/Utils/Parsec.hs +++ b/Distribution/Client/Utils/Parsec.hs @@ -16,7 +16,7 @@ renderParseError :: FilePath -> BS.ByteString - -> [PError] + -> NonEmpty PError -> [PWarning] -> String renderParseError filepath contents errors warnings = unlines $ diff --git a/Distribution/Client/VCS.hs b/Distribution/Client/VCS.hs --- a/Distribution/Client/VCS.hs +++ b/Distribution/Client/VCS.hs @@ -1,20 +1,16 @@ -{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} module Distribution.Client.VCS ( -- * VCS driver type VCS, vcsRepoType, vcsProgram, -- ** Type re-exports - SourceRepo, RepoType, - RepoKind, Program, ConfiguredProgram, - -- * Selecting amongst source repos - selectPackageSourceRepo, - -- * Validating 'SourceRepo's and configuring VCS drivers + validatePDSourceRepo, validateSourceRepo, validateSourceRepos, SourceRepoProblem(..), @@ -38,7 +34,8 @@ import Distribution.Client.Compat.Prelude import Distribution.Types.SourceRepo - ( SourceRepo(..), RepoType(..), RepoKind(..) ) + ( RepoType(..) ) +import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) import Distribution.Client.RebuildMonad ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) import Distribution.Verbosity as Verbosity @@ -51,6 +48,7 @@ , emptyProgramDb, requireProgram ) import Distribution.Version ( mkVersion ) +import qualified Distribution.PackageDescription as PD import Control.Monad ( mapM_ ) @@ -58,8 +56,6 @@ ( liftIO ) import qualified Data.Char as Char import qualified Data.Map as Map -import Data.Ord - ( comparing ) import Data.Either ( partitionEithers ) import System.FilePath @@ -80,9 +76,9 @@ -- | The program invocation(s) to get\/clone a repository into a fresh -- local directory. - vcsCloneRepo :: Verbosity + vcsCloneRepo :: forall f. Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -- Source URI -> FilePath -- Destination directory -> [ProgramInvocation], @@ -90,9 +86,9 @@ -- | The program invocation(s) to synchronise a whole set of /related/ -- repositories with corresponding local directories. Also returns the -- files that the command depends on, for change monitoring. - vcsSyncRepos :: Verbosity + vcsSyncRepos :: forall f. Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] } @@ -101,37 +97,8 @@ -- * Selecting repos and drivers -- ------------------------------------------------------------ --- | Pick the 'SourceRepo' to use to get the package sources from. --- --- Note that this does /not/ depend on what 'VCS' drivers we are able to --- successfully configure. It is based only on the 'SourceRepo's declared --- in the package, and optionally on a preferred 'RepoKind'. --- -selectPackageSourceRepo :: Maybe RepoKind - -> [SourceRepo] - -> Maybe SourceRepo -selectPackageSourceRepo preferredRepoKind = - listToMaybe - -- Sort repositories by kind, from This to Head to Unknown. Repositories - -- with equivalent kinds are selected based on the order they appear in - -- the Cabal description file. - . sortBy (comparing thisFirst) - -- If the user has specified the repo kind, filter out the repositories - -- they're not interested in. - . filter (\repo -> maybe True (repoKind repo ==) preferredRepoKind) - where - thisFirst :: SourceRepo -> Int - thisFirst r = case repoKind r of - RepoThis -> 0 - RepoHead -> case repoTag r of - -- If the type is 'head' but the author specified a tag, they - -- probably meant to create a 'this' repository but screwed up. - Just _ -> 0 - Nothing -> 1 - RepoKindUnknown _ -> 2 - data SourceRepoProblem = SourceRepoRepoTypeUnspecified - | SourceRepoRepoTypeUnsupported RepoType + | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType | SourceRepoLocationUnspecified deriving Show @@ -140,25 +107,42 @@ -- -- | It also returns the 'VCS' driver we should use to work with it. -- -validateSourceRepo :: SourceRepo - -> Either SourceRepoProblem - (SourceRepo, String, RepoType, VCS Program) +validateSourceRepo + :: SourceRepositoryPackage f + -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) validateSourceRepo = \repo -> do - rtype <- repoType repo ?! SourceRepoRepoTypeUnspecified - vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported rtype - uri <- repoLocation repo ?! SourceRepoLocationUnspecified + let rtype = srpType repo + vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype + let uri = srpLocation repo return (repo, uri, rtype, vcs) where a ?! e = maybe (Left e) Right a +validatePDSourceRepo + :: PD.SourceRepo + -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program) +validatePDSourceRepo repo = do + rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified + uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified + validateSourceRepo SourceRepositoryPackage + { srpType = rtype + , srpLocation = uri + , srpTag = PD.repoTag repo + , srpBranch = PD.repoBranch repo + , srpSubdir = PD.repoSubdir repo + } + where + a ?! e = maybe (Left e) Right a + + -- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return -- things in a convenient form to pass to 'configureVCSs', or to report -- problems. -- -validateSourceRepos :: [SourceRepo] - -> Either [(SourceRepo, SourceRepoProblem)] - [(SourceRepo, String, RepoType, VCS Program)] +validateSourceRepos :: [SourceRepositoryPackage f] + -> Either [(SourceRepositoryPackage f, SourceRepoProblem)] + [(SourceRepositoryPackage f, String, RepoType, VCS Program)] validateSourceRepos rs = case partitionEithers (map validateSourceRepo' rs) of (problems@(_:_), _) -> Left problems @@ -193,17 +177,15 @@ -- -- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first. -- -cloneSourceRepo :: Verbosity - -> VCS ConfiguredProgram - -> SourceRepo -- ^ Must have 'repoLocation' filled. - -> FilePath -- ^ Destination directory - -> IO () -cloneSourceRepo _ _ repo@SourceRepo{ repoLocation = Nothing } _ = - error $ "cloneSourceRepo: precondition violation, missing repoLocation: \"" - ++ show repo ++ "\". Validate using validateSourceRepo first." +cloneSourceRepo + :: Verbosity + -> VCS ConfiguredProgram + -> SourceRepositoryPackage f + -> [Char] + -> IO () cloneSourceRepo verbosity vcs - repo@SourceRepo{ repoLocation = Just srcuri } destdir = + repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir = mapM_ (runProgramInvocation verbosity) invocations where invocations = vcsCloneRepo vcs verbosity @@ -228,7 +210,7 @@ -- syncSourceRepos :: Verbosity -> VCS ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> Rebuild () syncSourceRepos verbosity vcs repos = do files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos @@ -260,7 +242,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -274,13 +256,13 @@ = "branch" | otherwise = "get" - tagArgs = case repoTag repo of + tagArgs = case srpTag repo of Nothing -> [] Just tag -> ["-r", "tag:" ++ tag] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr" bzrProgram :: Program @@ -306,7 +288,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -319,13 +301,13 @@ cloneCmd | programVersion prog >= Just (mkVersion [2,8]) = "clone" | otherwise = "get" - tagArgs = case repoTag repo of + tagArgs = case srpTag repo of Nothing -> [] Just tag -> ["-t", tag] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs" darcsProgram :: Program @@ -351,7 +333,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -361,11 +343,11 @@ ++ [ (programInvocation prog (checkoutArgs tag)) { progInvokeCwd = Just destdir } - | tag <- maybeToList (repoTag repo) ] + | tag <- maybeToList (srpTag repo) ] where cloneArgs = ["clone", srcuri, destdir] ++ branchArgs ++ verboseArg - branchArgs = case repoBranch repo of + branchArgs = case srpBranch repo of Just b -> ["--branch", b] Nothing -> [] checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"] @@ -373,7 +355,7 @@ vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _ _ [] = return [] vcsSyncRepos verbosity gitProg @@ -383,10 +365,10 @@ sequence_ [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) | (repo, localDir) <- secondaryRepos ] - return [ monitorDirectoryExistence dir + return [ monitorDirectoryExistence dir | dir <- (primaryLocalDir : map snd secondaryRepos) ] - vcsSyncRepo verbosity gitProg SourceRepo{..} localDir peer = do + vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do exists <- doesDirectoryExist localDir if exists then git localDir ["fetch"] @@ -404,10 +386,10 @@ Nothing -> [] Just peerLocalDir -> ["--reference", peerLocalDir] ++ verboseArg - where Just loc = repoLocation + where loc = srpLocation checkoutArgs = "checkout" : verboseArg ++ ["--detach", "--force" , checkoutTarget, "--" ] - checkoutTarget = fromMaybe "HEAD" (repoBranch `mplus` repoTag) + checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] gitProgram :: Program @@ -444,7 +426,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -453,17 +435,17 @@ where cloneArgs = ["clone", srcuri, destdir] ++ branchArgs ++ tagArgs ++ verboseArg - branchArgs = case repoBranch repo of + branchArgs = case srpBranch repo of Just b -> ["--branch", b] Nothing -> [] - tagArgs = case repoTag repo of + tagArgs = case srpTag repo of Just t -> ["--rev", t] Nothing -> [] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg" @@ -490,7 +472,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram - -> SourceRepo + -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation] @@ -503,7 +485,7 @@ vcsSyncRepos :: Verbosity -> ConfiguredProgram - -> [(SourceRepo, FilePath)] + -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn" diff --git a/Distribution/Deprecated/Text.hs b/Distribution/Deprecated/Text.hs --- a/Distribution/Deprecated/Text.hs +++ b/Distribution/Deprecated/Text.hs @@ -28,7 +28,6 @@ import Distribution.Deprecated.ReadP ((<++)) import qualified Distribution.Deprecated.ReadP as Parse -import Data.Functor.Identity (Identity (..)) import Distribution.Parsec import Distribution.Pretty import qualified Text.PrettyPrint as Disp diff --git a/Distribution/Deprecated/ViewAsFieldDescr.hs b/Distribution/Deprecated/ViewAsFieldDescr.hs --- a/Distribution/Deprecated/ViewAsFieldDescr.hs +++ b/Distribution/Deprecated/ViewAsFieldDescr.hs @@ -5,6 +5,7 @@ import Distribution.Client.Compat.Prelude hiding (get) import Prelude () +import qualified Data.List.NonEmpty as NE import Distribution.Parsec (parsec) import Distribution.Pretty import Distribution.ReadE (parsecToReadE) @@ -19,10 +20,10 @@ viewAsFieldDescr :: OptionField a -> FieldDescr a viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected" -viewAsFieldDescr (OptionField n dd) = FieldDescr n get set +viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set where - optDescr = head $ sortBy cmp dd + optDescr = head $ NE.sortBy cmp (d:|dd) cmp :: OptDescr a -> OptDescr a -> Ordering ReqArg{} `cmp` ReqArg{} = EQ diff --git a/Distribution/Solver/Modular.hs b/Distribution/Solver/Modular.hs --- a/Distribution/Solver/Modular.hs +++ b/Distribution/Solver/Modular.hs @@ -16,7 +16,7 @@ import Distribution.Solver.Compat.Prelude import qualified Data.Map as M -import Data.Set (Set, isSubsetOf) +import Data.Set (isSubsetOf) import Data.Ord import Distribution.Compat.Graph ( IsNode(..) ) 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 @@ -145,7 +145,9 @@ -- and then handle each instance in turn. addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = case M.lookup pn idx of - Nothing -> FailF (varToConflictSet (P qpn) `CS.union` goalReasonToCS gr) UnknownPackage + Nothing -> FailF + (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) + UnknownPackage Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> ([], POption i Nothing, bs { next = Instance qpn info })) (M.toList pis))) diff --git a/Distribution/Solver/Modular/ConfiguredConversion.hs b/Distribution/Solver/Modular/ConfiguredConversion.hs --- a/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -45,7 +45,7 @@ solverPkgExeDeps = fmap snd ds' } where - Just srcpkg = CI.lookupPackageId sidx pi + srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi where ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) ds' = fmap (partitionEithers . map convConfId) ds 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 @@ -10,7 +10,9 @@ -- > import qualified Distribution.Solver.Modular.ConflictSet as CS module Distribution.Solver.Modular.ConflictSet ( ConflictSet -- opaque + , Conflict(..) , ConflictMap + , OrderedVersionRange(..) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin #endif @@ -26,19 +28,21 @@ , delete , empty , singleton + , singletonWithConflict , size , member + , lookup , filter , fromList ) where -import Prelude hiding (filter) +import Prelude hiding (lookup) import Data.List (intercalate, sortBy) import Data.Map (Map) import Data.Set (Set) import Data.Function (on) +import qualified Data.Map.Strict as M import qualified Data.Set as S -import qualified Data.Map as M #ifdef DEBUG_CONFLICT_SETS import Data.Tree @@ -46,15 +50,14 @@ #endif import Distribution.Solver.Modular.Var +import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath --- | The set of variables involved in a solver conflict --- --- Since these variables should be preprocessed in some way, this type is --- kept abstract. +-- | The set of variables involved in a solver conflict, each paired with +-- details about the conflict. data ConflictSet = CS { - -- | The set of variables involved on the conflict - conflictSetToSet :: !(Set (Var QPN)) + -- | The set of variables involved in the conflict + conflictSetToMap :: !(Map (Var QPN) (Set Conflict)) #ifdef DEBUG_CONFLICT_SETS -- | The origin of the conflict set @@ -72,11 +75,48 @@ } deriving (Show) +-- | More detailed information about how a conflict set variable caused a +-- conflict. This information can be used to determine whether a second value +-- for that variable would lead to the same conflict. +-- +-- TODO: Handle dependencies under flags or stanzas. +data Conflict = + + -- | The conflict set variable represents a package which depends on the + -- specified problematic package. For example, the conflict set entry + -- '(P x, GoalConflict y)' means that package x introduced package y, and y + -- led to a conflict. + GoalConflict QPN + + -- | The conflict set variable represents a package with a constraint that + -- excluded the specified package and version. For example, the conflict set + -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that + -- package x's constraint on y excluded y-2.0. + | VersionConstraintConflict QPN Ver + + -- | The conflict set variable represents a package that was excluded by a + -- constraint from the specified package. For example, the conflict set + -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))' + -- means that package y's constraint 'x >= 2.0' excluded some version of x. + | VersionConflict QPN OrderedVersionRange + + -- | Any other conflict. + | OtherConflict + deriving (Eq, Ord, Show) + +-- | Version range with an 'Ord' instance. +newtype OrderedVersionRange = OrderedVersionRange VR + deriving (Eq, Show) + +-- TODO: Avoid converting the version ranges to strings. +instance Ord OrderedVersionRange where + compare = compare `on` show + instance Eq ConflictSet where - (==) = (==) `on` conflictSetToSet + (==) = (==) `on` conflictSetToMap instance Ord ConflictSet where - compare = compare `on` conflictSetToSet + compare = compare `on` conflictSetToMap showConflictSet :: ConflictSet -> String showConflictSet = intercalate ", " . map showVar . toList @@ -102,10 +142,10 @@ -------------------------------------------------------------------------------} toSet :: ConflictSet -> Set (Var QPN) -toSet = conflictSetToSet +toSet = M.keysSet . conflictSetToMap toList :: ConflictSet -> [Var QPN] -toList = S.toList . conflictSetToSet +toList = M.keys . conflictSetToMap union :: #ifdef DEBUG_CONFLICT_SETS @@ -113,7 +153,7 @@ #endif ConflictSet -> ConflictSet -> ConflictSet union cs cs' = CS { - conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet cs') + conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs') #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs']) #endif @@ -125,7 +165,7 @@ #endif [ConflictSet] -> ConflictSet unions css = CS { - conflictSetToSet = S.unions (map conflictSetToSet css) + conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc (map conflictSetOrigin css) #endif @@ -137,7 +177,7 @@ #endif Var QPN -> ConflictSet -> ConflictSet insert var cs = CS { - conflictSetToSet = S.insert var (conflictSetToSet cs) + conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] #endif @@ -145,7 +185,7 @@ delete :: Var QPN -> ConflictSet -> ConflictSet delete var cs = CS { - conflictSetToSet = S.delete var (conflictSetToSet cs) + conflictSetToMap = M.delete var (conflictSetToMap cs) } empty :: @@ -154,7 +194,7 @@ #endif ConflictSet empty = CS { - conflictSetToSet = S.empty + conflictSetToMap = M.empty #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif @@ -165,30 +205,28 @@ (?loc :: CallStack) => #endif Var QPN -> ConflictSet -singleton var = CS { - conflictSetToSet = S.singleton var +singleton var = singletonWithConflict var OtherConflict + +singletonWithConflict :: #ifdef DEBUG_CONFLICT_SETS + (?loc :: CallStack) => +#endif + Var QPN -> Conflict -> ConflictSet +singletonWithConflict var conflict = CS { + conflictSetToMap = M.singleton var (S.singleton conflict) +#ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif } size :: ConflictSet -> Int -size = S.size . conflictSetToSet +size = M.size . conflictSetToMap member :: Var QPN -> ConflictSet -> Bool -member var = S.member var . conflictSetToSet +member var = M.member var . conflictSetToMap -filter :: -#ifdef DEBUG_CONFLICT_SETS - (?loc :: CallStack) => -#endif - (Var QPN -> Bool) -> ConflictSet -> ConflictSet -filter p cs = CS { - conflictSetToSet = S.filter p (conflictSetToSet cs) -#ifdef DEBUG_CONFLICT_SETS - , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] -#endif - } +lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict) +lookup var = M.lookup var . conflictSetToMap fromList :: #ifdef DEBUG_CONFLICT_SETS @@ -196,7 +234,7 @@ #endif [Var QPN] -> ConflictSet fromList vars = CS { - conflictSetToSet = S.fromList vars + conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars] #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif 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 @@ -32,8 +32,11 @@ , QGoalReason , goalToVar , varToConflictSet - , goalReasonToCS - , dependencyReasonToCS + , goalReasonToConflictSet + , goalReasonToConflictSetWithConflict + , dependencyReasonToConflictSet + , dependencyReasonToConflictSetWithVersionConstraintConflict + , dependencyReasonToConflictSetWithVersionConflict ) where import Prelude () @@ -279,14 +282,30 @@ varToConflictSet :: Var QPN -> ConflictSet varToConflictSet = CS.singleton -goalReasonToCS :: GoalReason QPN -> ConflictSet -goalReasonToCS UserGoal = CS.empty -goalReasonToCS (DependencyGoal dr) = dependencyReasonToCS dr +-- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal +-- leads to a conflict. +goalReasonToConflictSet :: GoalReason QPN -> ConflictSet +goalReasonToConflictSet UserGoal = CS.empty +goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr +-- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the +-- conflict occurred, namely the conflict set variables caused a conflict by +-- introducing the given package goal. See the documentation for 'GoalConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'GoalReason' does not involve any flags or stanzas. +-- Otherwise, it falls back to calling 'goalReasonToConflictSet'. +goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet +goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas)) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal +goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr + -- | 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) = +-- It drops the values chosen for flag and stanza variables, which are only +-- needed for log messages. +dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet +dependencyReasonToConflictSet (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. @@ -297,3 +316,40 @@ stanzaToVar :: Stanza -> Var QPN stanzaToVar = S . SN qpn + +-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the +-- conflict occurred because the conflict set variables introduced a problematic +-- version constraint. See the documentation for 'VersionConstraintConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'DependencyReason' does not involve any flags or +-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. +dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN + -> Ver + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConstraintConflict + dependency excludedVersion dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConstraintConflict dependency excludedVersion + | otherwise = dependencyReasonToConflictSet dr + +-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the +-- conflict occurred because the conflict set variables introduced a version of +-- a package that was excluded by a version constraint. See the documentation +-- for 'VersionConflict'. +-- +-- This function currently only specifies the reason for the conflict in the +-- simple case where the 'DependencyReason' does not involve any flags or +-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. +dependencyReasonToConflictSetWithVersionConflict :: QPN + -> CS.OrderedVersionRange + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConflict + pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConflict pkgWithVersionConstraint constraint + | otherwise = dependencyReasonToConflictSet dr 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 @@ -7,19 +7,28 @@ import Data.Foldable as F import Data.List as L (foldl') +import Data.Maybe (fromMaybe) import Data.Map.Strict as M +import Data.Set as S +import Distribution.Simple.Setup (asBool) + import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Dependency +import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Log import Distribution.Solver.Modular.Message +import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.PSQ as P import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Tree +import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..)) +import Distribution.Solver.Types.Settings + (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..)) +import Distribution.Types.VersionRange (anyVersion) -- | This function takes the variable we're currently considering, a -- last conflict set and a list of children's logs. Each log yields @@ -43,25 +52,70 @@ -- with the (virtual) option not to choose anything for the current -- variable. See also the comments for 'avoidSet'. -- -backjump :: Maybe Int -> EnableBackjumping -> Var QPN - -> ConflictSet -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) +-- We can also skip a child if it does not resolve any of the conflicts paired +-- with the current variable in the previous child's conflict set. 'backjump' +-- takes a function to determine whether a child can be skipped. If the child +-- can be skipped, the function returns a new conflict set to be merged with the +-- previous conflict set. +-- +backjump :: forall w k a . Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + + -> (k -> S.Set CS.Conflict -> Maybe ConflictSet) + -- ^ Function that determines whether the given choice could resolve + -- the given conflict. It indicates false by returning 'Just', + -- with the new conflicts to be added to the conflict set. + + -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a) + -- ^ Function that logs the given choice that was skipped. + + -> Var QPN -- ^ The current variable. + + -> ConflictSet -- ^ Conflict set representing the reason that the goal + -- was introduced. + + -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) + -- ^ List of children's logs. + -> ExploreState -> ConflictSetLog a -backjump mbj (EnableBackjumping enableBj) var lastCS xs = - F.foldr combine avoidGoal xs CS.empty +backjump mbj enableBj fineGrainedConflicts couldResolveConflicts + logSkippedChoice var lastCS xs = + F.foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing where - combine :: forall a . (ExploreState -> ConflictSetLog a) - -> (ConflictSet -> ExploreState -> ConflictSetLog a) - -> ConflictSet -> ExploreState -> ConflictSetLog a - combine x f csAcc es = retryNoSolution (x es) next + combine :: (k, ExploreState -> ConflictSetLog a) + -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a + combine (k, x) f csAcc mPreviousCS es = + case (asBool fineGrainedConflicts, mPreviousCS) of + (True, Just previousCS) -> + case CS.lookup var previousCS of + Just conflicts -> + case couldResolveConflicts k conflicts of + Nothing -> retryNoSolution (x es) next + Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts) + _ -> skipChoice previousCS + _ -> retryNoSolution (x es) next where next :: ConflictSet -> ExploreState -> ConflictSetLog a - next !cs es' = if enableBj && not (var `CS.member` cs) + next !cs es' = if asBool enableBj && not (var `CS.member` cs) then skipLoggingBackjump cs es' - else f (csAcc `CS.union` cs) es' + else f (csAcc `CS.union` cs) (Just cs) es' + -- This function is for skipping the choice when it cannot resolve any + -- of the previous conflicts. + skipChoice :: ConflictSet -> ConflictSetLog a + skipChoice newCS = + retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' -> + f (csAcc `CS.union` cs') (Just cs') $ + + -- Update the conflict map with the conflict set, to make up for + -- skipping the whole subtree. + es' { esConflictMap = updateCM cs' (esConflictMap es') } + -- This function represents the option to not choose a value for this goal. - avoidGoal :: ConflictSet -> ExploreState -> ConflictSetLog a - avoidGoal cs !es = + avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a + avoidGoal cs _mPreviousCS !es = logBackjump mbj (cs `CS.union` lastCS) $ -- Use 'lastCS' below instead of 'cs' since we do not want to @@ -86,7 +140,7 @@ where reachedBjLimit = case mbj of Nothing -> const False - Just limit -> (== limit) + Just limit -> (>= limit) -- | Like 'retry', except that it only applies the input function when the -- backjump limit has not been reached. @@ -144,15 +198,20 @@ -- | A tree traversal that simultaneously propagates conflict sets up -- the tree from the leaves and creates a log. -exploreLog :: Maybe Int -> EnableBackjumping -> CountConflicts +exploreLog :: Maybe Int + -> EnableBackjumping + -> FineGrainedConflicts + -> CountConflicts + -> Index -> Tree Assignment QGoalReason -> ConflictSetLog (Assignment, RevDepMap) -exploreLog mbj enableBj (CountConflicts countConflicts) t = para go t initES +exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t = + para go t initES where getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) getBestGoal' - | countConflicts = \ ts cm -> getBestGoal cm ts - | otherwise = \ ts _ -> getFirstGoal ts + | asBool countConflicts = \ ts cm -> getBestGoal cm ts + | otherwise = \ ts _ -> getFirstGoal ts go :: TreeF Assignment QGoalReason (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) @@ -162,20 +221,29 @@ in failWith (Failure c fr) (NoSolution c es') go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) go (PChoiceF qpn _ gr ts) = - backjump mbj enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryP qpn k) (r es)) - (fmap fst ts) + backjump mbj enableBj fineGrainedConflicts + (couldResolveConflicts qpn) + (logSkippedPackage qpn) + (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryP qpn k) (r es)) + (fmap fst ts) go (FChoiceF qfn _ gr _ _ _ ts) = - backjump mbj enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryF qfn k) (r es)) - (fmap fst ts) + backjump mbj enableBj fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryF qfn k) (r es)) + (fmap fst ts) go (SChoiceF qsn _ gr _ ts) = - backjump mbj enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r es -> tryWith (TryS qsn k) (r es)) - (fmap fst ts) + backjump mbj enableBj fineGrainedConflicts + (\_ _ -> Nothing) + (const logSkippedChoiceSimple) + (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryS qsn k) (r es)) + (fmap fst ts) go (GoalChoiceF _ ts) = \ es -> let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) in continueWith (Next k) $ @@ -194,6 +262,59 @@ , esBackjumps = 0 } + -- Is it possible for this package instance (QPN and POption) to resolve any + -- of the conflicts that were caused by the previous instance? The default + -- is true, because it is always safe to explore a package instance. + -- Skipping it is an optimization. If false, it returns a new conflict set + -- to be merged with the previous one. + couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet + couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts = + let (PInfo deps _ _ _) = idx ! pn ! i + qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps + + couldBeResolved :: CS.Conflict -> Maybe ConflictSet + couldBeResolved CS.OtherConflict = Nothing + couldBeResolved (CS.GoalConflict conflictingDep) = + -- Check whether this package instance also has 'conflictingDep' + -- as a dependency (ignoring flag and stanza choices). + if F.null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep] + then Nothing + else Just CS.empty + couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) = + -- Check whether this package instance also excludes version + -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices). + let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ] + vrIntersection = L.foldl' (.&&.) anyVersion vrs + in if checkVR vrIntersection excludedVersion + then Nothing + else -- If we skip this package instance, we need to update the + -- conflict set to say that 'dep' was also excluded by + -- this package instance's constraint. + Just $ CS.singletonWithConflict (P dep) $ + CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection) + couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) = + -- Check whether this package instance's version is also excluded + -- by 'excludingVR'. + if checkVR excludingVR v + then Nothing + else -- If we skip this version, we need to update the conflict + -- set to say that the reverse dependency also excluded this + -- version. + Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v) + in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts) + + logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a + logSkippedPackage qpn pOption cs es = + tryWith (TryP qpn pOption) $ + failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $ + NoSolution cs es + + -- This function is used for flag and stanza choices, but it should not be + -- called, because there is currently no way to skip a value for a flag or + -- stanza. + logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a + logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es + -- | Build a conflict set corresponding to the (virtual) option not to -- choose a solution for a goal at all. -- @@ -219,8 +340,10 @@ -- conflict set. -- avoidSet :: Var QPN -> QGoalReason -> ConflictSet -avoidSet var gr = - CS.union (CS.singleton var) (goalReasonToCS gr) +avoidSet var@(P qpn) gr = + CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr) +avoidSet var gr = + CS.union (CS.singleton var) (goalReasonToConflictSet gr) -- | Interface. -- @@ -229,11 +352,15 @@ -- backtracking is completely disabled. backjumpAndExplore :: Maybe Int -> EnableBackjumping + -> FineGrainedConflicts -> CountConflicts + -> Index -> Tree d QGoalReason -> RetryLog Message SolverFailure (Assignment, RevDepMap) -backjumpAndExplore mbj enableBj countConflicts = - mapFailure convertFailure . exploreLog mbj enableBj countConflicts . assign +backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx = + mapFailure convertFailure + . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx + . assign where convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) convertFailure BackjumpLimit = BackjumpLimitReached 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 @@ -341,7 +341,7 @@ -- | Convert condition trees to flagged dependencies. Mutually -- recursive with 'convBranch'. See 'convBranch' for an explanation --- of all arguments preceeding the input 'CondTree'. +-- of all arguments preceding the input 'CondTree'. convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> Component -> (a -> BuildInfo) -> 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 @@ -1,5 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} + +-- TODO: remove this +{-# OPTIONS -fno-warn-incomplete-uni-patterns #-} module Distribution.Solver.Modular.Linking ( validateLinking ) where @@ -12,7 +15,6 @@ import Control.Monad.State import Data.Function (on) import Data.Map ((!)) -import Data.Set (Set) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Traversable as T @@ -29,7 +31,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath -import Distribution.Types.GenericPackageDescription (unFlagName) +import Distribution.Types.Flag (unFlagName) {------------------------------------------------------------------------------- Validation @@ -249,7 +251,7 @@ vs <- get let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs - lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToCS) dr1 dr2) lg lg' + lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg' updateLinkGroup lg'' (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do vs <- get 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 @@ -6,10 +6,16 @@ ) where import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Maybe (catMaybes, mapMaybe) import Prelude hiding (pi) import Distribution.Pretty (prettyShow) -- from Cabal +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package @@ -28,6 +34,7 @@ | TryF QFN Bool | TryS QSN Bool | Next (Goal QPN) + | Skip (Set CS.Conflict) | Success | Failure ConflictSet FailReason @@ -47,6 +54,8 @@ -- complex patterns 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 (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) = + goPSkip l qpn [i] conflicts 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)))) = @@ -63,6 +72,9 @@ 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 (Skip conflicts) ms) = + -- 'Skip' should always be handled by 'goPSkip' in the case above. + (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms) 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) @@ -85,11 +97,111 @@ goPReject l qpn is c fr ms = (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) + -- Handle many subsequent skipped package instances. + goPSkip :: Int + -> QPN + -> [POption] + -> Set CS.Conflict + -> Progress Message a b + -> Progress String a b + goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms)))) + | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms + goPSkip l qpn is conflicts ms = + let msg = "skipping: " + ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) + ++ showConflicts conflicts + in atLevel l msg (go l ms) + -- 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 + +-- | Display the set of 'Conflicts' for a skipped package version. +showConflicts :: Set CS.Conflict -> String +showConflicts conflicts = + " (has the same characteristics that caused the previous version to fail: " + ++ conflictMsg ++ ")" + where + conflictMsg :: String + conflictMsg = + if S.member CS.OtherConflict conflicts + then + -- This case shouldn't happen, because an unknown conflict should not + -- cause a version to be skipped. + "unknown conflict" + else let mergedConflicts = + [ showConflict qpn conflict + | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ] + in if L.null mergedConflicts + then + -- This case shouldn't happen unless backjumping is turned off. + "none" + else L.intercalate "; " mergedConflicts + + -- Merge conflicts to simplify the log message. + mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict + mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList + where + mergeConflict :: MergedPackageConflict + -> MergedPackageConflict + -> MergedPackageConflict + mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict { + isGoalConflict = + isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2 + , versionConstraintConflict = + L.nub $ versionConstraintConflict mergedConflict1 + ++ versionConstraintConflict mergedConflict2 + , versionConflict = + mergeVersionConflicts (versionConflict mergedConflict1) + (versionConflict mergedConflict2) + } + where + mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2) + mergeVersionConflicts (Just vr1) Nothing = Just vr1 + mergeVersionConflicts Nothing (Just vr2) = Just vr2 + mergeVersionConflicts Nothing Nothing = Nothing + + toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict) + toMergedConflict (CS.GoalConflict qpn) = + Just (qpn, MergedPackageConflict True [] Nothing) + toMergedConflict (CS.VersionConstraintConflict qpn v) = + Just (qpn, MergedPackageConflict False [v] Nothing) + toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) = + Just (qpn, MergedPackageConflict False [] (Just vr)) + toMergedConflict CS.OtherConflict = Nothing + + showConflict :: QPN -> MergedPackageConflict -> String + showConflict qpn mergedConflict = L.intercalate "; " conflictStrings + where + conflictStrings = catMaybes [ + case () of + () | isGoalConflict mergedConflict -> Just $ + "depends on '" ++ showQPN qpn ++ "'" ++ + (if null (versionConstraintConflict mergedConflict) + then "" + else " but excludes " + ++ showVersions (versionConstraintConflict mergedConflict)) + | not $ L.null (versionConstraintConflict mergedConflict) -> Just $ + "excludes '" ++ showQPN qpn + ++ "' " ++ showVersions (versionConstraintConflict mergedConflict) + | otherwise -> Nothing + , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'") + <$> versionConflict mergedConflict + ] + + showVersions [] = "no versions" + showVersions [v] = "version " ++ showVer v + showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs) + +-- | All conflicts related to one package, used for simplifying the display of +-- a 'Set CS.Conflict'. +data MergedPackageConflict = MergedPackageConflict { + isGoalConflict :: Bool + , versionConstraintConflict :: [Ver] + , versionConflict :: Maybe VR + } showQPNPOpt :: QPN -> POption -> String showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = 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 @@ -18,7 +18,8 @@ , unPN ) where -import Data.List as L +import Prelude () +import Distribution.Solver.Compat.Prelude import Distribution.Package -- from Cabal import Distribution.Deprecated.Text (display) @@ -57,14 +58,12 @@ -- | String representation of an instance. showI :: I -> String showI (I v InRepo) = showVer v -showI (I v (Inst uid)) = showVer v ++ "/installed" ++ shortId uid +showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid where - -- A hack to extract the beginning of the package ABI hash - shortId = snip (splitAt 4) (++ "...") - . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':) - . display - snip p f xs = case p xs of - (ys, zs) -> (if L.null zs then id else f) ys + extractPackageAbiHash xs = + case first reverse $ break (=='-') $ reverse (display xs) of + (ys, []) -> ys + (ys, _) -> '-' : ys -- | Package instance. A package name and an instance. data PI qpn = PI qpn I 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 @@ -343,7 +343,9 @@ onlyConstrained p = trav go where go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn) - = FailF (varToConflictSet (P v) `CS.union` goalReasonToCS gr) NotExplicit + = FailF + (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr) + NotExplicit go x = x 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 @@ -57,6 +57,7 @@ data SolverConfig = SolverConfig { reorderGoals :: ReorderGoals, countConflicts :: CountConflicts, + fineGrainedConflicts :: FineGrainedConflicts, minimizeConflictSet :: MinimizeConflictSet, independentGoals :: IndependentGoals, avoidReinstalls :: AvoidReinstalls, @@ -104,7 +105,9 @@ where explorePhase = backjumpAndExplore (maxBackjumps sc) (enableBackjumping sc) + (fineGrainedConflicts sc) (countConflicts sc) + idx detectCycles = traceTree "cycles.json" id . detectCyclesPhase heuristicsPhase = let heuristicsTree = traceTree "heuristics.json" id 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 @@ -320,7 +320,7 @@ -> (ExposedComponent -> DependencyReason QPN -> FailReason) -> Conflict mkConflict comp dr mkFailure = - (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure comp dr) + (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) buildableProvidedComps :: [ExposedComponent] buildableProvidedComps = [comp | (comp, IsBuildable True) <- M.toList providedComps] @@ -393,13 +393,13 @@ 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) + else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) extendSingle a (LDep dr (Lang lang)) = if langSupported lang then Right a - else Left (dependencyReasonToCS dr, UnsupportedLanguage lang) + else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) extendSingle a (LDep dr (Pkg pn vr)) = if pkgPresent pn vr then Right a - else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr) + else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) = let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of @@ -448,14 +448,14 @@ merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2)) | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 | otherwise = - Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i | otherwise = - Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + Left ( createConflictSetForVersionConflict p v vs1 vr vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) @@ -467,7 +467,7 @@ go ((vr, comp1, vs1) : vros) | checkVR vr v = go vros | otherwise = - Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 + Left ( createConflictSetForVersionConflict p v vs2 vr vs1 , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) @@ -479,6 +479,45 @@ -- no negative performance impact. vrOrigins ++ [(vr, comp2, vs2)]) +-- | Creates a conflict set representing a conflict between a version constraint +-- and the fixed version chosen for a package. +createConflictSetForVersionConflict :: QPN + -> Ver + -> DependencyReason QPN + -> VR + -> DependencyReason QPN + -> ConflictSet +createConflictSetForVersionConflict pkg + conflictingVersion + versionDR@(DependencyReason p1 _ _) + conflictingVersionRange + versionRangeDR@(DependencyReason p2 _ _) = + let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss) + in + -- The solver currently only optimizes the case where there is a conflict + -- between the version chosen for a package and a version constraint that + -- is not under any flags or stanzas. Here is how we check for this case: + -- + -- (1) Choosing a specific version for a package foo is implemented as + -- adding a dependency from foo to that version of foo (See + -- extendWithPackageChoice), so we check that the DependencyReason + -- contains the current package and no flag or stanza choices. + -- + -- (2) We check that the DependencyReason for the version constraint also + -- contains no flag or stanza choices. + -- + -- When these criteria are not met, we fall back to calling + -- dependencyReasonToConflictSet. + if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR) + then let cs1 = dependencyReasonToConflictSetWithVersionConflict + p2 + (CS.OrderedVersionRange conflictingVersionRange) + versionDR + cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict + pkg conflictingVersion versionRangeDR + in cs1 `CS.union` cs2 + else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR + -- | Takes a list of new dependencies and uses it to try to update the map of -- known component dependencies. It returns a failure when a new dependency -- requires a component that is missing or unbuildable in a previously chosen @@ -512,7 +551,7 @@ -> (QPN -> ExposedComponent -> FailReason) -> Conflict mkConflict qpn comp dr mkFailure = - (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure qpn comp) + (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) buildableComps :: Map comp IsBuildable -> [comp] buildableComps comps = [comp | (comp, IsBuildable True) <- M.toList comps] 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.Solver.Compat.Prelude hiding (empty,zip) +import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) import qualified Data.Map as Map import Data.Foldable (fold) @@ -62,6 +62,7 @@ deriving (Show, Eq, Ord, Generic) instance Binary Component +instance Structured Component -- | Dependency for a single component. type ComponentDep a = (Component, a) @@ -89,6 +90,7 @@ traverse f = fmap ComponentDeps . traverse f . unComponentDeps instance Binary a => Binary (ComponentDeps a) +instance Structured a => Structured (ComponentDeps a) componentNameToComponent :: CN.ComponentName -> Component componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib 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 @@ -5,7 +5,8 @@ ) where import GHC.Generics (Generic) -import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Binary (Binary) +import Distribution.Utils.Structured (Structured) -- | Source of a 'PackageConstraint'. data ConstraintSource = @@ -56,6 +57,7 @@ deriving (Eq, Show, Generic) instance Binary ConstraintSource +instance Structured ConstraintSource -- | Description of a 'ConstraintSource'. showConstraintSource :: ConstraintSource -> String diff --git a/Distribution/Solver/Types/InstSolverPackage.hs b/Distribution/Solver/Types/InstSolverPackage.hs --- a/Distribution/Solver/Types/InstSolverPackage.hs +++ b/Distribution/Solver/Types/InstSolverPackage.hs @@ -4,6 +4,7 @@ ) where import Distribution.Compat.Binary (Binary(..)) +import Distribution.Utils.Structured (Structured) import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.SolverId @@ -13,7 +14,7 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) import GHC.Generics (Generic) --- | An 'InstSolverPackage' is a pre-existing installed pacakge +-- | An 'InstSolverPackage' is a pre-existing installed package -- specified by the dependency solver. data InstSolverPackage = InstSolverPackage { instSolverPkgIPI :: InstalledPackageInfo, @@ -23,6 +24,7 @@ deriving (Eq, Show, Generic) instance Binary InstSolverPackage +instance Structured InstSolverPackage instance Package InstSolverPackage where packageId i = diff --git a/Distribution/Solver/Types/OptionalStanza.hs b/Distribution/Solver/Types/OptionalStanza.hs --- a/Distribution/Solver/Types/OptionalStanza.hs +++ b/Distribution/Solver/Types/OptionalStanza.hs @@ -8,10 +8,11 @@ import GHC.Generics (Generic) import Data.Typeable -import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Binary (Binary) import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..), defaultComponentRequestedSpec) import Data.List (foldl') +import Distribution.Utils.Structured (Structured) data OptionalStanza = TestStanzas @@ -32,3 +33,4 @@ addStanza enabled BenchStanzas = enabled { benchmarksRequested = True } instance Binary OptionalStanza +instance Structured OptionalStanza 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 @@ -18,12 +18,13 @@ packageConstraintToDependency ) where -import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Binary (Binary) import Distribution.Package (PackageName) import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) import Distribution.Types.Dependency (Dependency(..)) import Distribution.Types.LibraryName (LibraryName(..)) import Distribution.Version (VersionRange, simplifyVersionRange) +import Distribution.Utils.Structured (Structured) import Distribution.Solver.Compat.Prelude ((<<>>)) import Distribution.Solver.Types.OptionalStanza @@ -102,6 +103,7 @@ deriving (Eq, Show, Generic) instance Binary PackageProperty +instance Structured PackageProperty -- | Pretty-prints a package property. dispPackageProperty :: PackageProperty -> Disp.Doc 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 @@ -50,7 +50,8 @@ import Control.Exception (assert) import qualified Data.Map as Map -import Data.List (groupBy, isInfixOf) +import Data.List (isInfixOf) +import qualified Data.List.NonEmpty as NE import Distribution.Package ( PackageName, unPackageName, PackageIdentifier(..) @@ -136,9 +137,9 @@ where fixBucket = -- out of groups of duplicates, later ones mask earlier ones -- but Map.fromListWith (++) constructs groups in reverse order - map head + map NE.head -- Eq instance for PackageIdentifier is wrong, so use Ord: - . groupBy (\a b -> EQ == comparing packageId a b) + . NE.groupBy (\a b -> EQ == comparing packageId a b) -- relies on sortBy being a stable sort so we -- can pick consistently among duplicates . sortBy (comparing packageId) 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 @@ -31,7 +31,7 @@ import Distribution.Package (PkgconfigName, mkPkgconfigName) import Distribution.Parsec import Distribution.Simple.Program - (ProgramDb, getProgramOutput, pkgConfigProgram, requireProgram) + (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram) import Distribution.Simple.Utils (info) import Distribution.Types.PkgconfigVersion import Distribution.Types.PkgconfigVersionRange @@ -50,30 +50,36 @@ deriving (Show, Generic, Typeable) instance Binary PkgConfigDb +instance Structured PkgConfigDb -- | Query pkg-config for the list of installed packages, together -- with their versions. Return a `PkgConfigDb` encapsulating this -- information. readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do - (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb - pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] - -- The output of @pkg-config --list-all@ also includes a description - -- for each package, which we do not need. - let pkgNames = map (takeWhile (not . isSpace)) pkgList - pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig - ("--modversion" : pkgNames) - (return . pkgConfigDbFromList . zip pkgNames) pkgVersions - where - -- For when pkg-config invocation fails (possibly because of a - -- too long command line). - ioErrorHandler :: IOException -> IO PkgConfigDb - ioErrorHandler e = do - info verbosity ("Failed to query pkg-config, Cabal will continue" - ++ " without solving for pkg-config constraints: " - ++ show e) - return NoPkgConfigDb + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> noPkgConfig "Cannot find pkg-config program" + Just (pkgConfig, _) -> do + pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] + -- The output of @pkg-config --list-all@ also includes a description + -- for each package, which we do not need. + let pkgNames = map (takeWhile (not . isSpace)) pkgList + pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig + ("--modversion" : pkgNames) + (return . pkgConfigDbFromList . zip pkgNames) pkgVersions + where + -- For when pkg-config invocation fails (possibly because of a + -- too long command line). + noPkgConfig extra = do + info verbosity ("Failed to query pkg-config, Cabal will continue" + ++ " without solving for pkg-config constraints: " + ++ extra) + return NoPkgConfigDb + ioErrorHandler :: IOException -> IO PkgConfigDb + ioErrorHandler e = noPkgConfig (show e) + -- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs @@ -134,10 +140,11 @@ -- > pkg-config --variable pc_path pkg-config -- getDefPath = handle ioErrorHandler $ do - (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb - parseSearchPath <$> - getProgramOutput verbosity pkgConfig - ["--variable", "pc_path", "pkg-config"] + mpkgConfig <- needProgram verbosity pkgConfigProgram progdb + case mpkgConfig of + Nothing -> return [] + Just (pkgConfig, _) -> parseSearchPath <$> + getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] parseSearchPath str = case lines str of diff --git a/Distribution/Solver/Types/ResolverPackage.hs b/Distribution/Solver/Types/ResolverPackage.hs --- a/Distribution/Solver/Types/ResolverPackage.hs +++ b/Distribution/Solver/Types/ResolverPackage.hs @@ -11,7 +11,8 @@ import Distribution.Solver.Types.SolverPackage import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Binary (Binary) +import Distribution.Utils.Structured (Structured) import Distribution.Compat.Graph (IsNode(..)) import Distribution.Package (Package(..), HasUnitId(..)) import Distribution.Simple.Utils (ordNub) @@ -27,6 +28,7 @@ deriving (Eq, Show, Generic) instance Binary loc => Binary (ResolverPackage loc) +instance Structured loc => Structured (ResolverPackage loc) instance Package (ResolverPackage loc) where packageId (PreExisting ipkg) = packageId ipkg diff --git a/Distribution/Solver/Types/Settings.hs b/Distribution/Solver/Types/Settings.hs --- a/Distribution/Solver/Types/Settings.hs +++ b/Distribution/Solver/Types/Settings.hs @@ -11,11 +11,13 @@ , OnlyConstrained(..) , EnableBackjumping(..) , CountConflicts(..) + , FineGrainedConflicts(..) , SolveExecutables(..) ) where import Distribution.Simple.Setup ( BooleanFlag(..) ) -import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Binary (Binary) +import Distribution.Utils.Structured (Structured) import Distribution.Pretty ( Pretty(pretty) ) import Distribution.Deprecated.Text ( Text(parse) ) import GHC.Generics (Generic) @@ -29,6 +31,9 @@ newtype CountConflicts = CountConflicts Bool deriving (BooleanFlag, Eq, Generic, Show) +newtype FineGrainedConflicts = FineGrainedConflicts Bool + deriving (BooleanFlag, Eq, Generic, Show) + newtype MinimizeConflictSet = MinimizeConflictSet Bool deriving (BooleanFlag, Eq, Generic, Show) @@ -62,6 +67,7 @@ instance Binary ReorderGoals instance Binary CountConflicts +instance Binary FineGrainedConflicts instance Binary IndependentGoals instance Binary MinimizeConflictSet instance Binary AvoidReinstalls @@ -70,6 +76,18 @@ instance Binary AllowBootLibInstalls instance Binary OnlyConstrained instance Binary SolveExecutables + +instance Structured ReorderGoals +instance Structured CountConflicts +instance Structured FineGrainedConflicts +instance Structured IndependentGoals +instance Structured MinimizeConflictSet +instance Structured AvoidReinstalls +instance Structured ShadowPkgs +instance Structured StrongFlags +instance Structured AllowBootLibInstalls +instance Structured OnlyConstrained +instance Structured SolveExecutables instance Pretty OnlyConstrained where pretty OnlyConstrainedAll = PP.text "all" diff --git a/Distribution/Solver/Types/SolverId.hs b/Distribution/Solver/Types/SolverId.hs --- a/Distribution/Solver/Types/SolverId.hs +++ b/Distribution/Solver/Types/SolverId.hs @@ -5,7 +5,8 @@ where -import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Binary (Binary) +import Distribution.Utils.Structured (Structured) import Distribution.Package (PackageId, Package(..), UnitId) import GHC.Generics (Generic) @@ -19,6 +20,7 @@ deriving (Eq, Ord, Generic) instance Binary SolverId +instance Structured SolverId instance Show SolverId where show = show . solverSrcId 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 @@ -3,7 +3,8 @@ ( SolverPackage(..) ) where -import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Binary (Binary) +import Distribution.Utils.Structured (Structured) import Distribution.Package ( Package(..) ) import Distribution.PackageDescription ( FlagAssignment ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) @@ -29,6 +30,7 @@ deriving (Eq, Show, Generic) instance Binary loc => Binary (SolverPackage loc) +instance Structured loc => Structured (SolverPackage loc) instance Package (SolverPackage loc) where packageId = packageId . solverPkgSource diff --git a/Distribution/Solver/Types/SourcePackage.hs b/Distribution/Solver/Types/SourcePackage.hs --- a/Distribution/Solver/Types/SourcePackage.hs +++ b/Distribution/Solver/Types/SourcePackage.hs @@ -12,8 +12,9 @@ import Data.ByteString.Lazy (ByteString) import GHC.Generics (Generic) -import Distribution.Compat.Binary (Binary(..)) +import Distribution.Compat.Binary (Binary) import Data.Typeable +import Distribution.Utils.Structured (Structured) -- | A package description along with the location of the package sources. -- @@ -25,7 +26,8 @@ } deriving (Eq, Show, Generic, Typeable) -instance (Binary loc) => Binary (SourcePackage loc) +instance Binary loc => Binary (SourcePackage loc) +instance Structured loc => Structured (SourcePackage loc) instance Package (SourcePackage a) where packageId = packageInfoId diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -224,8 +224,8 @@ # >= 2.6.0.2 && < 2.7 NETWORK_VER="2.7.0.0"; NETWORK_VER_REGEXP="2\.[0-7]\." # >= 2.0 && < 2.7 -CABAL_VER="3.0.0.0"; CABAL_VER_REGEXP="3\.0\.[0-9]" - # >= 2.5 && < 2.6 +CABAL_VER="3.2.0.0"; CABAL_VER_REGEXP="3\.2\.[0-9]" + # >= 3.2 && < 3.3 TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 MTL_VER="2.2.2"; MTL_VER_REGEXP="[2]\." @@ -260,14 +260,14 @@ # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?" # 0.0.* -HACKAGE_SECURITY_VER="0.5.3.0"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.((2\.[2-9]|[3-9])|3)" - # >= 0.5.2 && < 0.6 +HACKAGE_SECURITY_VER="0.6.0.0"; HACKAGE_SECURITY_VER_REGEXP="0\.6\." + # >= 0.7.0.0 && < 0.7 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 DIGEST_VER="0.0.1.2"; DIGEST_REGEXP="0\.0\.(1\.[2-9]|[2-9]\.?)" # >= 0.0.1.2 && < 0.1 -ZIP_ARCHIVE_VER="0.3.3"; ZIP_ARCHIVE_REGEXP="0\.3\.[3-9]" - # >= 0.3.3 && < 0.4 +LUKKO_VER="0.1.1"; LUKKO_VER_REGEXP="0\.1\.[1-9]" + # >= 0.1.1 && <0.2 HACKAGE_URL="https://hackage.haskell.org/package" @@ -471,7 +471,7 @@ info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} info_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} -info_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP} +info_pkg "lukko" ${LUKKO_VER} ${LUKKO_REGEXP} info_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} @@ -509,7 +509,7 @@ do_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} do_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} do_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} -do_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP} +do_pkg "lukko" ${LUKKO_VER} ${LUKKO_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 @@ -4,7 +4,7 @@ -- To update this file, edit 'cabal-install.cabal.pp' and run -- 'make cabal-install-prod' in the project's root folder. Name: cabal-install -Version: 3.0.0.0 +Version: 3.2.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -16,12 +16,11 @@ License-File: LICENSE Author: Cabal Development Team (see AUTHORS file) Maintainer: Cabal Development Team -Copyright: 2003-2019, Cabal Development Team +Copyright: 2003-2020, Cabal Development Team Category: Distribution Build-type: Custom Extra-Source-Files: README.md bash-completion/cabal bootstrap.sh changelog - tests/README.md -- Generated with 'make gen-extra-source-files' -- Do NOT edit this section manually; instead, run the script. @@ -122,6 +121,11 @@ default: False manual: True +Flag lukko + description: Use @lukko@ for file-locking + default: True + manual: True + custom-setup setup-depends: Cabal >= 2.2, @@ -133,12 +137,14 @@ main-is: Main.hs hs-source-dirs: main default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances + if impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances + ghc-options: -rtsopts -threaded -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a @@ -171,13 +177,14 @@ Distribution.Client.CmdInstall.ClientInstallFlags Distribution.Client.CmdRepl Distribution.Client.CmdRun + Distribution.Client.CmdRun.ClientRunFlags Distribution.Client.CmdTest Distribution.Client.CmdLegacy Distribution.Client.CmdSdist Distribution.Client.Compat.Directory Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FileLock Distribution.Client.Compat.FilePerms + Distribution.Client.Compat.Orphans Distribution.Client.Compat.Prelude Distribution.Client.Compat.Process Distribution.Client.Compat.Semaphore @@ -197,6 +204,7 @@ Distribution.Client.Glob Distribution.Client.GlobalFlags Distribution.Client.Haddock + Distribution.Client.HashValue Distribution.Client.HttpUtils Distribution.Client.IndexUtils Distribution.Client.IndexUtils.Timestamp @@ -239,7 +247,7 @@ Distribution.Client.SetupWrapper Distribution.Client.SolverInstallPlan Distribution.Client.SourceFiles - Distribution.Client.SourceRepoParse + Distribution.Client.SourceRepo Distribution.Client.SrcDist Distribution.Client.Store Distribution.Client.Tar @@ -308,11 +316,11 @@ build-depends: async >= 2.0 && < 2.3, array >= 0.4 && < 0.6, - base >= 4.8 && < 4.13, + base >= 4.8 && < 4.14, base16-bytestring >= 0.1.1 && < 0.2, binary >= 0.7.3 && < 0.9, bytestring >= 0.10.6.0 && < 0.11, - Cabal == 3.0.*, + Cabal == 3.2.*, containers >= 0.5.6.2 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, deepseq >= 1.4.1.1 && < 1.5, @@ -331,13 +339,15 @@ stm >= 2.0 && < 2.6, tar >= 0.5.0.3 && < 0.6, time >= 1.5.0.1 && < 1.10, + transformers >= 0.4.2.0 && < 0.6, zlib >= 0.5.3 && < 0.7, - hackage-security >= 0.5.2.2 && < 0.6, + hackage-security >= 0.6.0.0 && < 0.7, text >= 1.2.3 && < 1.3, parsec >= 3.1.13.0 && < 3.2 if !impl(ghc >= 8.0) build-depends: fail == 4.9.* + build-depends: semigroups >= 0.18.3 && <0.20 if flag(native-dns) if os(windows) @@ -349,6 +359,11 @@ build-depends: Win32 >= 2 && < 3 else build-depends: unix >= 2.5 && < 2.9 + + if flag(lukko) + build-depends: lukko >= 0.1 && <0.2 + else + build-depends: base >= 4.10 if flag(debug-expensive-assertions) cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,9 +1,44 @@ -*-change-log-*- +3.2.0.0 Herbert Valerio Riedel April 2020 + * `v2-build` (and other `v2-`prefixed commands) now accept the + `--benchmark-option(s)` flags, which pass options to benchmark executables + (analogous to how `--test-option(s)` works). (#6209) + * Add solver optimization to skip a version of a package if it does not resolve + any conflicts encountered in the last version, controlled by flag + '--fine-grained-conflicts'. (#5918) + * `cabal v2-exec` doesn't fail in clean package (#6479) + * Show full ABI hash for installed packages in solver log (#5892) + * Create incoming directory even for empty packages (#4130) + * Start GHCi with `main-is` module in scope (#6311) + * Implement `--benchmark-options` for `v2-bench` (#6224) + * Fix store-dir in ghc env files generated by `cabal install --lib + --package-env` (#6298) + * `cabal v2-run` works with `.lhs` files (#6134) + * `subdir` in source-repository-package accepts multiple entries (#5472) + +3.0.1.0 Herbert Valerio Riedel April 2020 + * Create store incoming directory + ([#4130](https://github.com/haskell/cabal/issues/4130)) + * `fetchRepoTarball` output is not marked + ([#6385](https://github.com/haskell/cabal/pull/6385)) + * Update `setupMinCabalVersionConstraint` for GHC-8.8 + ([#6217](https://github.com/haskell/cabal/pull/6217)) + * Implement `cabal install --ignore-project` + ([#5919](https://github.com/haskell/cabal/issues/5919)) + * `cabal install executable` solver isn't affected by default + environment contents + ([#6410](https://github.com/haskell/cabal/issues/6410)) + * Use `lukko` for file locking + ([#6345](https://github.com/haskell/cabal/pull/6345)) + * Use `hackage-security-0.6` + ([#6388](https://github.com/haskell/cabal/pull/6388)) + * Other dependency upgrades + 3.0.0.0 Mikhail Glushenkov August 2019 * `v2-haddock` fails on `haddock` failures (#5977) * `v2-run` works when given `File.lhs` literate file. (#6134) - * Parse comma-seperated lists for extra-prog-path, extra-lib-dirs, extra-framework-dirs, + * Parse comma-separated lists for extra-prog-path, extra-lib-dirs, extra-framework-dirs, and extra-include-dirs as actual lists. (#5420) * `v2-repl` no longer changes directory to a randomized temporary folder when used outside of a project. (#5544) @@ -504,7 +539,7 @@ 0.6.2 Duncan Coutts Feb 2009 * The upgrade command has been disabled in this release * The configure and install commands now have consistent behaviour - * Reduce the tendancy to re-install already existing packages + * Reduce the tendency to re-install already existing packages * The --constraint= flag now works for the install command * New --preference= flag for soft constraints / version preferences * Improved bootstrap.sh script, smarter and better error checking diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -236,9 +236,9 @@ mainWorker :: [String] -> IO () mainWorker args = do - hasScript <- if not (null args) - then CmdRun.validScript (head args) - else return False + maybeScriptAndArgs <- case args of + [] -> return Nothing + (h:tl) -> (\b -> if b then Just (h:|tl) else Nothing) <$> CmdRun.validScript h topHandler $ case commandsRun (globalCommand commands) commands args of @@ -253,9 +253,8 @@ -> printNumericVersion CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts - CommandErrors errs - | hasScript -> CmdRun.handleShebang (head args) (tail args) - | otherwise -> printErrors errs + CommandErrors errs -> maybe (printErrors errs) go maybeScriptAndArgs where + go (script:|scriptArgs) = CmdRun.handleShebang script scriptArgs CommandReadyToGo action -> do globalFlags' <- updateSandboxConfigFileFlag globalFlags action globalFlags' @@ -554,9 +553,10 @@ either (const onNoPkgDesc) (const onPkgDesc) pkgDesc -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> Action -installAction (configFlags, _, installFlags, _, _) _ globalFlags +installAction (configFlags, _, installFlags, _, _, _) _ globalFlags | fromFlagOrDefault False (installOnly installFlags) = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags @@ -565,10 +565,12 @@ nixShellIfSandboxed verb dist globalFlags config useSandbox $ setupWrapper verb setupOpts Nothing - installCommand (const mempty) (const []) + installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty)) + (const []) installAction - (configFlags, configExFlags, installFlags, haddockFlags, testFlags) + ( configFlags, configExFlags, installFlags + , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags) @@ -607,6 +609,9 @@ testFlags' = Cabal.defaultTestFlags `mappend` savedTestFlags config `mappend` testFlags { testDistPref = toFlag dist } + benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend` + savedBenchmarkFlags config `mappend` + benchmarkFlags { benchmarkDistPref = toFlag dist } globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags' -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the @@ -643,7 +648,7 @@ comp platform progdb' useSandbox mSandboxPkgInfo globalFlags' configFlags'' configExFlags' - installFlags' haddockFlags' testFlags' + installFlags' haddockFlags' testFlags' benchmarkFlags' targets where @@ -885,9 +890,10 @@ withRepoContext verbosity globalFlags' $ \repoContext -> update verbosity updateFlags repoContext -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags) +upgradeAction :: ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> Action -upgradeAction (configFlags, _, _, _, _) _ _ = die' verbosity $ +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 " diff --git a/tests/README.md b/tests/README.md deleted file mode 100644 --- a/tests/README.md +++ /dev/null @@ -1,27 +0,0 @@ -Integration Tests -================= - -Each test is a shell script. Tests that share files (e.g., `.cabal` files) are -grouped under a common sub-directory of [IntegrationTests]. The framework -copies the whole group's directory before running each test, which allows tests -to reuse files, yet run independently. A group's tests are further divided into -`should_run` and `should_fail` directories, based on the expected exit status. -For example, the test -`IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh` has access -to all files under `exec` and is expected to fail. - -Tests can specify their expected output. For a test named `x.sh`, `x.out` -specifies `stdout` and `x.err` specifies `stderr`. Both files are optional. -The framework expects an exact match between lines in the file and output, -except for lines beginning with "RE:", which are interpreted as regular -expressions. - -[IntegrationTests.hs] defines several environment variables: - -* `CABAL` - The path to the executable being tested. -* `GHC_PKG` - The path to ghc-pkg. -* `CABAL_ARGS` - A common set of arguments for running cabal. -* `CABAL_ARGS_NO_CONFIG_FILE` - `CABAL_ARGS` without `--config-file`. - -[IntegrationTests]: IntegrationTests -[IntegrationTests.hs]: IntegrationTests.hs