diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs --- a/Distribution/Client/BuildReports/Anonymous.hs +++ b/Distribution/Client/BuildReports/Anonymous.hs @@ -26,8 +26,6 @@ -- showList, ) where -import Distribution.Client.Types - ( ConfiguredPackage(..) ) import qualified Distribution.Client.Types as BR ( BuildResult, BuildFailure(..), BuildSuccess(..) , DocsResult(..), TestsResult(..) ) @@ -36,7 +34,7 @@ import qualified Paths_cabal_install (version) import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Package(packageId) ) + ( PackageIdentifier(..), PackageName(..) ) import Distribution.PackageDescription ( FlagName(..), FlagAssignment ) --import Distribution.Version @@ -44,7 +42,7 @@ import Distribution.System ( OS, Arch ) import Distribution.Compiler - ( CompilerId ) + ( CompilerId(..) ) import qualified Distribution.Text as Text ( Text(disp, parse) ) import Distribution.ParseUtils @@ -106,7 +104,8 @@ } data InstallOutcome - = DependencyFailed PackageIdentifier + = PlanningFailed + | DependencyFailed PackageIdentifier | DownloadFailed | UnpackFailed | SetupFailed @@ -120,12 +119,11 @@ data Outcome = NotTried | Failed | Ok deriving Eq -new :: OS -> Arch -> CompilerId -- -> Version - -> ConfiguredPackage -> BR.BuildResult - -> BuildReport -new os' arch' comp (ConfiguredPackage pkg flags _ deps) result = +new :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment + -> [PackageIdentifier] -> BR.BuildResult -> BuildReport +new os' arch' comp pkgid flags deps result = BuildReport { - package = packageId pkg, + package = pkgid, os = os', arch = arch', compiler = comp, @@ -139,6 +137,7 @@ } where convertInstallOutcome = case result of + Left BR.PlanningFailed -> PlanningFailed Left (BR.DependentFailed p) -> DependencyFailed p Left (BR.DownloadFailed _) -> DownloadFailed Left (BR.UnpackFailed _) -> UnpackFailed @@ -276,6 +275,7 @@ flag -> return (FlagName flag, True) instance Text.Text InstallOutcome where + disp PlanningFailed = Disp.text "PlanningFailed" disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid disp DownloadFailed = Disp.text "DownloadFailed" disp UnpackFailed = Disp.text "UnpackFailed" @@ -289,6 +289,7 @@ parse = do name <- Parse.munch1 Char.isAlphaNum case name of + "PlanningFailed" -> return PlanningFailed "DependencyFailed" -> do Parse.skipSpaces pkgid <- Text.parse return (DependencyFailed pkgid) 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 @@ -20,6 +20,7 @@ -- * 'InstallPlan' support fromInstallPlan, + fromPlanningFailure, ) where import qualified Distribution.Client.BuildReports.Anonymous as BuildReport @@ -30,13 +31,17 @@ import Distribution.Client.InstallPlan ( InstallPlan ) +import Distribution.Package + ( PackageId, packageId ) +import Distribution.PackageDescription + ( FlagAssignment ) import Distribution.Simple.InstallDirs ( PathTemplate, fromPathTemplate , initialPathTemplateEnv, substPathTemplate ) import Distribution.System ( Platform(Platform) ) import Distribution.Compiler - ( CompilerId ) + ( CompilerId(..), CompilerInfo(..) ) import Distribution.Simple.Utils ( comparing, equating ) @@ -49,7 +54,7 @@ import System.Directory ( createDirectoryIfMissing ) -storeAnonymous :: [(BuildReport, Repo)] -> IO () +storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO () storeAnonymous reports = sequence_ [ appendFile file (concatMap format reports') | (repo, reports') <- separate reports @@ -59,7 +64,7 @@ where format r = '\n' : BuildReport.show r ++ "\n" - separate :: [(BuildReport, Repo)] + separate :: [(BuildReport, Maybe Repo)] -> [(Repo, [BuildReport])] separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) . map concat @@ -69,13 +74,14 @@ . onlyRemote repoName (_,_,rrepo) = remoteRepoName rrepo - onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)] + onlyRemote :: [(BuildReport, Maybe Repo)] -> [(BuildReport, Repo, RemoteRepo)] onlyRemote rs = [ (report, repo, remoteRepo) - | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] + | (report, Just repo@Repo { repoKind = Left remoteRepo }) <- rs ] -storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> Platform -> IO () -storeLocal templates reports platform = sequence_ +storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)] + -> Platform -> IO () +storeLocal cinfo templates reports platform = sequence_ [ do createDirectoryIfMissing True (takeDirectory file) appendFile file output --TODO: make this concurrency safe, either lock the report file or make @@ -93,7 +99,12 @@ fromPathTemplate (substPathTemplate env template) where env = initialPathTemplateEnv (BuildReport.package report) - (BuildReport.compiler report) + -- ToDo: In principle, we can support $pkgkey, but only + -- if the configure step succeeds. So add a Maybe field + -- to the build report, and either use that or make up + -- a fake identifier if it's not available. + (error "storeLocal: package key not available") + cinfo platform groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) @@ -104,26 +115,38 @@ -- * InstallPlan support -- ------------------------------------------------------------ -fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)] +fromInstallPlan :: InstallPlan -> [(BuildReport, Maybe Repo)] fromInstallPlan plan = catMaybes . map (fromPlanPackage platform comp) . InstallPlan.toList $ plan where platform = InstallPlan.planPlatform plan - comp = InstallPlan.planCompiler plan + comp = compilerInfoId (InstallPlan.planCompiler plan) fromPlanPackage :: Platform -> CompilerId -> InstallPlan.PlanPackage - -> Maybe (BuildReport, Repo) + -> Maybe (BuildReport, Maybe Repo) fromPlanPackage (Platform arch os) comp planPackage = case planPackage of - - InstallPlan.Installed pkg@(ReadyPackage (SourcePackage { - packageSource = RepoTarballPackage repo _ _ }) _ _ _) result - -> Just $ (BuildReport.new os arch comp - (readyPackageToConfiguredPackage pkg) (Right result), repo) + InstallPlan.Installed (ReadyPackage srcPkg flags _ deps) result + -> Just $ ( BuildReport.new os arch comp + (packageId srcPkg) flags (map packageId deps) + (Right result) + , extractRepo srcPkg) - InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage { - packageSource = RepoTarballPackage repo _ _ }) _ _ _) result - -> Just $ (BuildReport.new os arch comp pkg (Left result), repo) + InstallPlan.Failed (ConfiguredPackage srcPkg flags _ deps) result + -> Just $ ( BuildReport.new os arch comp + (packageId srcPkg) flags deps + (Left result) + , extractRepo srcPkg ) _ -> Nothing + + where + extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ }) = Just repo + extractRepo _ = Nothing + +fromPlanningFailure :: Platform -> CompilerId + -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)] +fromPlanningFailure (Platform arch os) comp pkgids flags = + [ (BuildReport.new os arch comp pkgid flags [] (Left PlanningFailed), Nothing) + | pkgid <- pkgids ] diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs --- a/Distribution/Client/BuildReports/Upload.hs +++ b/Distribution/Client/BuildReports/Upload.hs @@ -51,10 +51,14 @@ } case rspCode response of (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location +#if defined(VERSION_network_uri) + return $ relativeTo rel uri +#elif defined(VERSION_network) #if MIN_VERSION_network(2,4,0) return $ relativeTo rel uri #else relativeTo rel uri +#endif #endif | Header HdrLocation location <- rspHeaders response ] -> return $ buildId diff --git a/Distribution/Client/Compat/Environment.hs b/Distribution/Client/Compat/Environment.hs --- a/Distribution/Client/Compat/Environment.hs +++ b/Distribution/Client/Compat/Environment.hs @@ -20,7 +20,6 @@ #ifdef mingw32_HOST_OS import GHC.Windows -import Foreign.Safe import Foreign.C import Control.Monad #else diff --git a/Distribution/Client/Compat/Time.hs b/Distribution/Client/Compat/Time.hs --- a/Distribution/Client/Compat/Time.hs +++ b/Distribution/Client/Compat/Time.hs @@ -11,20 +11,29 @@ import Data.Time (getCurrentTime, diffUTCTime) #else import System.Time (ClockTime(..), getClockTime - ,diffClockTimes, normalizeTimeDiff, tdDay) + ,diffClockTimes, normalizeTimeDiff, tdDay, tdHour) #endif #if defined mingw32_HOST_OS +#if MIN_VERSION_base(4,7,0) +import Data.Bits ((.|.), finiteBitSize, unsafeShiftL) +#else import Data.Bits ((.|.), bitSize, unsafeShiftL) +#endif import Data.Int (Int32) import Data.Word (Word64) import Foreign (allocaBytes, peekByteOff) import System.IO.Error (mkIOError, doesNotExistErrorType) import System.Win32.Types (BOOL, DWORD, LPCTSTR, LPVOID, withTString) +#ifdef x86_64_HOST_ARCH +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif -foreign import stdcall "windows.h GetFileAttributesExW" +foreign import CALLCONV "windows.h GetFileAttributesExW" c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL getFileAttributesEx :: String -> LPVOID -> IO BOOL @@ -46,11 +55,7 @@ #else -#if MIN_VERSION_base(4,5,0) import Foreign.C.Types (CTime(..)) -#else -import Foreign.C.Types (CTime) -#endif import System.Posix.Files (getFileStatus, modificationTime) #endif @@ -87,8 +92,13 @@ windowsTimeToPOSIXSeconds dwLow dwHigh = let wINDOWS_TICK = 10000000 sEC_TO_UNIX_EPOCH = 11644473600 +#if MIN_VERSION_base(4,7,0) + qwTime = (fromIntegral dwHigh `unsafeShiftL` finiteBitSize dwHigh) + .|. (fromIntegral dwLow) +#else qwTime = (fromIntegral dwHigh `unsafeShiftL` bitSize dwHigh) .|. (fromIntegral dwLow) +#endif res = ((qwTime :: Word64) `div` wINDOWS_TICK) - sEC_TO_UNIX_EPOCH -- TODO: What if the result is not representable as POSIX seconds? @@ -110,17 +120,17 @@ #endif -- | Return age of given file in days. -getFileAge :: FilePath -> IO Int +getFileAge :: FilePath -> IO Double getFileAge file = do t0 <- getModificationTime file #if MIN_VERSION_directory(1,2,0) t1 <- getCurrentTime - let days = truncate $ (t1 `diffUTCTime` t0) / posixDayLength + return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength #else t1 <- getClockTime - let days = (tdDay . normalizeTimeDiff) (t1 `diffClockTimes` t0) + let dt = normalizeTimeDiff (t1 `diffClockTimes` t0) + return $ fromIntegral ((24 * tdDay dt) + tdHour dt) / 24.0 #endif - return days getCurTime :: IO EpochTime getCurTime = do diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -33,7 +33,9 @@ haddockFlagsFields, installDirsFields, withProgramsFields, - withProgramOptionsFields + withProgramOptionsFields, + userConfigDiff, + userConfigUpdate ) where import Distribution.Client.Types @@ -47,9 +49,11 @@ , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand , showRepo, parseRepo ) +import Distribution.Utils.NubList + ( NubList, fromNubList, toNubList) import Distribution.Simple.Compiler - ( OptimisationLevel(..) ) + ( DebugInfoLevel(..), OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags , HaddockFlags(..), haddockOptions, defaultHaddockFlags @@ -77,20 +81,20 @@ import Distribution.Simple.Program ( defaultProgramConfiguration ) import Distribution.Simple.Utils - ( notice, warn, lowercase ) + ( die, notice, warn, lowercase, cabalVersion ) import Distribution.Compiler ( CompilerFlavor(..), defaultCompilerFlavor ) import Distribution.Verbosity ( Verbosity, normal ) import Data.List - ( partition, find ) + ( partition, find, foldl' ) import Data.Maybe ( fromMaybe ) import Data.Monoid ( Monoid(..) ) import Control.Monad - ( unless, foldM, liftM ) + ( unless, foldM, liftM, liftM2 ) import qualified Distribution.Compat.ReadP as Parse ( option ) import qualified Text.PrettyPrint as Disp @@ -109,6 +113,13 @@ ( getEnvironment ) import Distribution.Compat.Exception ( catchIO ) +import qualified Paths_cabal_install + ( version ) +import Data.Version + ( showVersion ) +import Data.Char + ( isSpace ) +import qualified Data.Map as M -- -- * Configuration saved in the config file @@ -178,13 +189,13 @@ in case b' of [] -> a' _ -> b' - lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> [a]) - -> [a] + lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a) + -> NubList a lastNonEmptyNL' field subfield = let a' = subfield . field $ a b' = subfield . field $ b - in case b' of [] -> a' - _ -> b' + in case fromNubList b' of [] -> a' + _ -> b' combinedSavedGlobalFlags = GlobalFlags { globalVersion = combine globalVersion, @@ -222,6 +233,7 @@ installSummaryFile = lastNonEmptyNL installSummaryFile, installLogFile = combine installLogFile, installBuildReports = combine installBuildReports, + installReportPlanningFailure = combine installReportPlanningFailure, installSymlinkBinDir = combine installSymlinkBinDir, installOneShot = combine installOneShot, installNumJobs = combine installNumJobs, @@ -249,6 +261,7 @@ -- TODO: NubListify configConfigureArgs = lastNonEmpty configConfigureArgs, configOptimization = combine configOptimization, + configDebugInfo = combine configDebugInfo, configProgPrefix = combine configProgPrefix, configProgSuffix = combine configProgSuffix, -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'. @@ -273,12 +286,16 @@ configConstraints = lastNonEmpty configConstraints, -- TODO: NubListify configDependencies = lastNonEmpty configDependencies, + configInstantiateWith = lastNonEmpty configInstantiateWith, -- TODO: NubListify configConfigurationsFlags = lastNonEmpty configConfigurationsFlags, configTests = combine configTests, configBenchmarks = combine configBenchmarks, + configCoverage = combine configCoverage, configLibCoverage = combine configLibCoverage, - configExactConfiguration = combine configExactConfiguration + configExactConfiguration = combine configExactConfiguration, + configFlagError = combine configFlagError, + configRelocatable = combine configRelocatable } where combine = combine' savedConfigureFlags @@ -410,14 +427,14 @@ return mempty { savedGlobalFlags = mempty { globalCacheDir = toFlag cacheDir, - globalRemoteRepos = [defaultRemoteRepo], + globalRemoteRepos = toNubList [defaultRemoteRepo], globalWorldFile = toFlag worldFile }, savedConfigureFlags = mempty { - configProgramPathExtra = extraPath + configProgramPathExtra = toNubList extraPath }, savedInstallFlags = mempty { - installSummaryFile = [toPathTemplate (logsDir "build.log")], + installSummaryFile = toNubList [toPathTemplate (logsDir "build.log")], installBuildReports= toFlag AnonymousReports, installNumJobs = toFlag Nothing } @@ -500,11 +517,9 @@ return conf Just (ParseFailed err) -> do let (line, msg) = locatedErrorMsg err - warn verbosity $ + die $ "Error parsing config file " ++ configFile ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg - warn verbosity "Using default configuration." - initialSavedConfig where addBaseConf body = do @@ -538,6 +553,9 @@ ,"-- Lines (like this one) beginning with '--' are comments." ,"-- Be careful with spaces and indentation because they are" ,"-- used to indicate layout for nested sections." + ,"" + ,"-- Cabal library version: " ++ showVersion cabalVersion + ,"-- cabal-install version: " ++ showVersion Paths_cabal_install.version ,"","" ] @@ -570,12 +588,12 @@ configFieldDescriptions = toSavedConfig liftGlobalFlag - (commandOptions globalCommand ParseArgs) + (commandOptions (globalCommand []) ParseArgs) ["version", "numeric-version", "config-file", "sandbox-config-file"] [] ++ toSavedConfig liftConfigFlag (configureOptions ParseArgs) - (["builddir", "configure-option", "constraint", "dependency"] + (["builddir", "constraint", "dependency"] ++ map fieldName installDirsFields) --FIXME: this is only here because viewAsFieldDescr gives us a parser @@ -584,10 +602,11 @@ [simpleField "compiler" (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) configHcFlavor (\v flags -> flags { configHcFlavor = v }) - -- TODO: The following is a temporary fix. The "optimization" field is - -- OptArg, and viewAsFieldDescr fails on that. Instead of a hand-written - -- hackaged parser and printer, we should handle this case properly in - -- the library. + -- TODO: The following is a temporary fix. The "optimization" + -- and "debug-info" fields are OptArg, and viewAsFieldDescr + -- fails on that. Instead of a hand-written hackaged parser + -- and printer, we should handle this case properly in the + -- library. ,liftField configOptimization (\v flags -> flags { configOptimization = v }) $ let name = "optimization" in FieldDescr name @@ -609,6 +628,29 @@ lstr = lowercase str caseWarning = PWarning $ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") + ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $ + let name = "debug-info" in + FieldDescr name + (\f -> case f of + Flag NoDebugInfo -> Disp.text "False" + Flag MinimalDebugInfo -> Disp.text "1" + Flag NormalDebugInfo -> Disp.text "True" + Flag MaximalDebugInfo -> Disp.text "3" + _ -> Disp.empty) + (\line str _ -> case () of + _ | str == "False" -> ParseOk [] (Flag NoDebugInfo) + | str == "True" -> ParseOk [] (Flag NormalDebugInfo) + | str == "0" -> ParseOk [] (Flag NoDebugInfo) + | str == "1" -> ParseOk [] (Flag MinimalDebugInfo) + | str == "2" -> ParseOk [] (Flag NormalDebugInfo) + | str == "3" -> ParseOk [] (Flag MaximalDebugInfo) + | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo) + | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo) + | otherwise -> ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") ] ++ toSavedConfig liftConfigExFlag @@ -648,7 +690,8 @@ [ liftGlobalFlag $ listField "repos" (Disp.text . showRepo) parseRepo - globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs }) + (fromNubList . globalRemoteRepos) + (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) , liftGlobalFlag $ simpleField "cachedir" (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ) @@ -721,10 +764,7 @@ configProgramPaths = paths, configProgramArgs = args }, - savedHaddockFlags = haddockFlags { - haddockProgramPaths = paths, - haddockProgramArgs = args - }, + savedHaddockFlags = haddockFlags, savedUserInstallDirs = user, savedGlobalInstallDirs = global } @@ -829,3 +869,60 @@ withProgramOptionsFields = map viewAsFieldDescr $ programConfigurationOptions defaultProgramConfiguration ParseArgs id (++) + +-- | Get the differences (as a pseudo code diff) between the user's +-- '~/.cabal/config' and the one that cabal would generate if it didn't exist. +userConfigDiff :: GlobalFlags -> IO [String] +userConfigDiff globalFlags = do + userConfig <- loadConfig normal (globalConfigFile globalFlags) mempty + testConfig <- liftM2 mappend baseSavedConfig initialSavedConfig + return $ reverse . foldl' createDiff [] . M.toList + $ M.unionWith combine + (M.fromList . map justFst $ filterShow testConfig) + (M.fromList . map justSnd $ filterShow userConfig) + where + justFst (a, b) = (a, (Just b, Nothing)) + justSnd (a, b) = (a, (Nothing, Just b)) + + combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b) + combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b) + combine x y = error $ "Can't happen : userConfigDiff " ++ show x ++ " " ++ show y + + createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String] + createDiff acc (key, (Just a, Just b)) + | a == b = acc + | otherwise = ("+ " ++ key ++ ": " ++ b) : ("- " ++ key ++ ": " ++ a) : acc + createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc + createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc + createDiff acc (_, (Nothing, Nothing)) = acc + + filterShow :: SavedConfig -> [(String, String)] + filterShow cfg = map keyValueSplit + . filter (\s -> not (null s) && any (== ':') s) + . map nonComment + . lines + $ showConfig cfg + + nonComment [] = [] + nonComment ('-':'-':_) = [] + nonComment (x:xs) = x : nonComment xs + + topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace + + keyValueSplit s = + let (left, right) = break (== ':') s + in (topAndTail left, topAndTail (drop 1 right)) + + +-- | Update the user's ~/.cabal/config' keeping the user's customizations. +userConfigUpdate :: Verbosity -> GlobalFlags -> IO () +userConfigUpdate verbosity globalFlags = do + userConfig <- loadConfig normal (globalConfigFile globalFlags) mempty + newConfig <- liftM2 mappend baseSavedConfig initialSavedConfig + commentConf <- commentSavedConfig + cabalFile <- defaultConfigFile + let backup = cabalFile ++ ".backup" + notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." + renameFile cabalFile backup + notice verbosity $ "Writing merged config to " ++ cabalFile ++ "." + writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig) diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -30,12 +30,11 @@ ( userToPackageConstraint ) import Distribution.Simple.Compiler - ( CompilerId(..), Compiler(compilerId) - , PackageDB(..), PackageDBStack ) + ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration ) import Distribution.Simple.Setup ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault ) -import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Utils ( defaultPackageDesc ) import qualified Distribution.InstalledPackageInfo as Installed @@ -64,6 +63,8 @@ chooseCabalVersion configExFlags maybeVersion = maybe defaultVersionRange thisVersion maybeVersion where + -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed + -- for '--allow-newer' to work. allowNewer = fromFlagOrDefault False $ fmap isAllowNewer (configAllowNewer configExFlags) @@ -125,6 +126,7 @@ (configDistPref configFlags), useLoggingHandle = Nothing, useWorkingDir = Nothing, + useWin32CleanHack = False, forceExternalSetupMethod = False, setupCacheLock = Nothing } @@ -147,13 +149,13 @@ planLocalPackage :: Verbosity -> Compiler -> Platform -> ConfigFlags -> ConfigExFlags - -> PackageIndex + -> InstalledPackageIndex -> SourcePackageDb -> IO (Progress String String InstallPlan) planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex (SourcePackageDb _ packagePrefs) = do pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity - solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp) + solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerInfo comp) let -- We create a local package and ask to resolve a dependency on it localPkg = SourcePackage { @@ -200,7 +202,7 @@ (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies platform (compilerId comp) solver resolverParams) + return (resolveDependencies platform (compilerInfo comp) solver resolverParams) -- | Call an installer for an 'SourcePackage' but override the configure @@ -212,7 +214,7 @@ -- NB: when updating this function, don't forget to also update -- 'installReadyPackage' in D.C.Install. configurePackage :: Verbosity - -> Platform -> CompilerId + -> Platform -> CompilerInfo -> SetupScriptOptions -> ConfigFlags -> ReadyPackage diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -64,6 +64,7 @@ import Distribution.Client.Dependency.Modular ( modularResolver, SolverConfig(..) ) import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) @@ -72,6 +73,7 @@ , SourcePackage(..) ) import Distribution.Client.Dependency.Types ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..) + , debugPackageConstraint , AllowNewer(..), PackagePreferences(..), InstalledPreference(..) , PackagesPreferenceDefault(..) , Progress(..), foldProgress ) @@ -91,7 +93,7 @@ ( Version(..), VersionRange, anyVersion, thisVersion, withinRange , removeUpperBound, simplifyVersionRange ) import Distribution.Compiler - ( CompilerId(..), CompilerFlavor(..) ) + ( CompilerId(..), CompilerInfo(..), CompilerFlavor(..) ) import Distribution.System ( Platform ) import Distribution.Simple.Utils @@ -101,7 +103,7 @@ import Distribution.Verbosity ( Verbosity ) -import Data.List (maximumBy, foldl') +import Data.List (maximumBy, foldl', intercalate) import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set @@ -120,7 +122,7 @@ depResolverConstraints :: [PackageConstraint], depResolverPreferences :: [PackagePreference], depResolverPreferenceDefault :: PackagesPreferenceDefault, - depResolverInstalledPkgIndex :: InstalledPackageIndex.PackageIndex, + depResolverInstalledPkgIndex :: InstalledPackageIndex, depResolverSourcePkgIndex :: PackageIndex.PackageIndex SourcePackage, depResolverReorderGoals :: Bool, depResolverIndependentGoals :: Bool, @@ -130,6 +132,14 @@ depResolverMaxBackjumps :: Maybe Int } +debugDepResolverParams :: DepResolverParams -> String +debugDepResolverParams p = + "targets: " ++ intercalate ", " (map display (depResolverTargets p)) + ++ "\nconstraints: " + ++ concatMap (("\n " ++) . debugPackageConstraint) (depResolverConstraints p) + ++ "\npreferences: " + ++ concatMap (("\n " ++) . debugPackagePreference) (depResolverPreferences p) + ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) -- | A package selection preference for a particular package. -- @@ -145,7 +155,16 @@ -- | If we prefer versions of packages that are already installed. | PackageInstalledPreference PackageName InstalledPreference -basicDepResolverParams :: InstalledPackageIndex.PackageIndex +-- | Provide a textual representation of a package preference +-- for debugging purposes. +-- +debugPackagePreference :: PackagePreference -> String +debugPackagePreference (PackageVersionPreference pn vr) = + display pn ++ " " ++ display (simplifyVersionRange vr) +debugPackagePreference (PackageInstalledPreference pn ip) = + display pn ++ " " ++ show ip + +basicDepResolverParams :: InstalledPackageIndex -> PackageIndex.PackageIndex SourcePackage -> DepResolverParams basicDepResolverParams installedPkgIndex sourcePkgIndex = @@ -394,7 +413,7 @@ hideInstalledPackagesAllVersions (depResolverTargets params) params -standardInstallPolicy :: InstalledPackageIndex.PackageIndex +standardInstallPolicy :: InstalledPackageIndex -> SourcePackageDb -> [PackageSpecifier SourcePackage] -> DepResolverParams @@ -463,11 +482,12 @@ -- * Interface to the standard resolver -- ------------------------------------------------------------ -chooseSolver :: Verbosity -> PreSolver -> CompilerId -> IO Solver +chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver chooseSolver _ AlwaysTopDown _ = return TopDown chooseSolver _ AlwaysModular _ = return Modular -chooseSolver verbosity Choose (CompilerId f v) = do - let chosenSolver | f == GHC && v <= Version [7] [] = TopDown +chooseSolver verbosity Choose cinfo = do + let (CompilerId f v) = compilerInfoId cinfo + chosenSolver | f == GHC && v <= Version [7] [] = TopDown | otherwise = Modular msg TopDown = warn verbosity "Falling back to topdown solver for GHC < 7." msg Modular = info verbosity "Choosing modular solver." @@ -485,7 +505,7 @@ -- logging messages and the final result or an error. -- resolveDependencies :: Platform - -> CompilerId + -> CompilerInfo -> Solver -> DepResolverParams -> Progress String String InstallPlan @@ -497,13 +517,15 @@ resolveDependencies platform comp solver params = - fmap (mkInstallPlan platform comp) + Step (debugDepResolverParams finalparams) + $ fmap (mkInstallPlan platform comp) $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing strFlags maxBkjumps) platform comp installedPkgIndex sourcePkgIndex preferences constraints targets where - DepResolverParams + + finalparams @ (DepResolverParams targets constraints prefs defpref installedPkgIndex @@ -513,7 +535,7 @@ noReinstalls shadowing strFlags - maxBkjumps = dontUpgradeNonUpgradeablePackages + maxBkjumps) = dontUpgradeNonUpgradeablePackages -- TODO: -- The modular solver can properly deal with broken -- packages and won't select them. So the @@ -530,15 +552,18 @@ -- It checks that the plan is valid, or it's an error in the dep resolver. -- mkInstallPlan :: Platform - -> CompilerId + -> CompilerInfo -> [InstallPlan.PlanPackage] -> InstallPlan mkInstallPlan platform comp pkgIndex = - case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) of + let index = InstalledPackageIndex.fromList pkgIndex in + case InstallPlan.new platform comp index of Right plan -> plan Left problems -> error $ unlines $ "internal error: could not construct a valid install plan." : "The proposed (invalid) plan contained the following problems:" : map InstallPlan.showPlanProblem problems + ++ "Proposed plan:" + : [InstallPlan.showPlanIndex index] -- | Give an interpretation to the global 'PackagesPreference' as diff --git a/Distribution/Client/Dependency/Modular.hs b/Distribution/Client/Dependency/Modular.hs --- a/Distribution/Client/Dependency/Modular.hs +++ b/Distribution/Client/Dependency/Modular.hs @@ -35,13 +35,13 @@ -- | Ties the two worlds together: classic cabal-install vs. the modular -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver -modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns = +modularResolver sc (Platform arch os) cinfo iidx sidx pprefs pcs pns = fmap (uncurry postprocess) $ -- convert install plan logToProgress (maxBackjumps sc) $ -- convert log format into progress format solve sc idx pprefs gcs pns where -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cid (shadowPkgs sc) (strongFlags sc) iidx sidx + idx = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) iidx sidx -- Constraints have to be converted into a finite map indexed by PN. gcs = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs) diff --git a/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs --- a/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs +++ b/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs @@ -13,13 +13,13 @@ import Distribution.Client.Dependency.Modular.Configured import Distribution.Client.Dependency.Modular.Package -mkPlan :: Platform -> CompilerId -> - SI.PackageIndex -> CI.PackageIndex SourcePackage -> +mkPlan :: Platform -> CompilerInfo -> + SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> [CP QPN] -> Either [PlanProblem] InstallPlan mkPlan plat comp iidx sidx cps = - new plat comp (CI.fromList (map (convCP iidx sidx) cps)) + new plat comp (SI.fromList (map (convCP iidx sidx) cps)) -convCP :: SI.PackageIndex -> CI.PackageIndex SourcePackage -> +convCP :: SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> CP QPN -> PlanPackage convCP iidx sidx (CP qpi fa es ds) = case convPI qpi of diff --git a/Distribution/Client/Dependency/Modular/Dependency.hs b/Distribution/Client/Dependency/Modular/Dependency.hs --- a/Distribution/Client/Dependency/Modular/Dependency.hs +++ b/Distribution/Client/Dependency/Modular/Dependency.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} module Distribution.Client.Dependency.Modular.Dependency where import Prelude hiding (pi) @@ -19,7 +20,7 @@ -- TODO: This isn't the ideal location to declare the type, -- but we need them for constrained instances. data Var qpn = P qpn | F (FN qpn) | S (SN qpn) - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Functor) -- | For computing conflict sets, we map flag choice vars to a -- single flag choice. This means that all flag choices are treated @@ -36,11 +37,6 @@ showVar (F qfn) = showQFN qfn showVar (S qsn) = showQSN qsn -instance Functor Var where - fmap f (P n) = P (f n) - fmap f (F fn) = F (fmap f fn) - fmap f (S sn) = S (fmap f sn) - type ConflictSet qpn = Set (Var qpn) showCS :: ConflictSet QPN -> String @@ -51,11 +47,7 @@ -- is for convenience. Otherwise, it is a list of version ranges paired with -- the goals / variables that introduced them. data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn] - deriving (Eq, Show) - -instance Functor CI where - fmap f (Fixed i g) = Fixed i (fmap f g) - fmap f (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, fmap f y)) vrs) + deriving (Eq, Show, Functor) instance ResetGoal CI where resetGoal g (Fixed i _) = Fixed i g @@ -108,13 +100,7 @@ Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) | Stanza (SN qpn) (TrueFlaggedDeps qpn) | Simple (Dep qpn) - deriving (Eq, Show) - -instance Functor FlaggedDep where - fmap f (Flagged x y tt ff) = Flagged (fmap f x) y - (fmap (fmap f) tt) (fmap (fmap f) ff) - fmap f (Stanza x tt) = Stanza (fmap f x) (fmap (fmap f) tt) - fmap f (Simple d) = Simple (fmap f d) + deriving (Eq, Show, Functor) type TrueFlaggedDeps qpn = FlaggedDeps qpn type FalseFlaggedDeps qpn = FlaggedDeps qpn @@ -122,7 +108,7 @@ -- | A dependency (constraint) associates a package name with a -- constrained instance. data Dep qpn = Dep qpn (CI qpn) - deriving (Eq, Show) + deriving (Eq, Show, Functor) showDep :: Dep QPN -> String showDep (Dep qpn (Fixed i (Goal v _)) ) = @@ -133,9 +119,6 @@ showDep (Dep qpn ci ) = showQPN qpn ++ showCI ci -instance Functor Dep where - fmap f (Dep x y) = Dep (f x) (fmap f y) - instance ResetGoal Dep where resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci) @@ -146,10 +129,7 @@ -- | Goals are solver variables paired with information about -- why they have been introduced. data Goal qpn = Goal (Var qpn) (GoalReasonChain qpn) - deriving (Eq, Show) - -instance Functor Goal where - fmap f (Goal v grs) = Goal (fmap f v) (fmap (fmap f) grs) + deriving (Eq, Show, Functor) class ResetGoal f where resetGoal :: Goal qpn -> f qpn -> f qpn @@ -168,13 +148,7 @@ | PDependency (PI qpn) | FDependency (FN qpn) Bool | SDependency (SN qpn) - deriving (Eq, Show) - -instance Functor GoalReason where - fmap _ UserGoal = UserGoal - fmap f (PDependency pi) = PDependency (fmap f pi) - fmap f (FDependency fn b) = FDependency (fmap f fn) b - fmap f (SDependency sn) = SDependency (fmap f sn) + deriving (Eq, Show, Functor) -- | The first element is the immediate reason. The rest are the reasons -- for the reasons ... diff --git a/Distribution/Client/Dependency/Modular/Flag.hs b/Distribution/Client/Dependency/Modular/Flag.hs --- a/Distribution/Client/Dependency/Modular/Flag.hs +++ b/Distribution/Client/Dependency/Modular/Flag.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} module Distribution.Client.Dependency.Modular.Flag where import Data.Map as M @@ -10,15 +11,12 @@ -- | Flag name. Consists of a package instance and the flag identifier itself. data FN qpn = FN (PI qpn) Flag - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Functor) -- | Extract the package name from a flag name. getPN :: FN qpn -> qpn getPN (FN (PI qpn _) _) = qpn -instance Functor FN where - fmap f (FN x y) = FN (fmap f x) y - -- | Flag identifier. Just a string. type Flag = FlagName @@ -42,10 +40,7 @@ -- | Stanza name. Paired with a package name, much like a flag. data SN qpn = SN (PI qpn) OptionalStanza - deriving (Eq, Ord, Show) - -instance Functor SN where - fmap f (SN x y) = SN (fmap f x) y + deriving (Eq, Ord, Show, Functor) -- | Qualified stanza name. type QSN = SN QPN diff --git a/Distribution/Client/Dependency/Modular/IndexConversion.hs b/Distribution/Client/Dependency/Modular/IndexConversion.hs --- a/Distribution/Client/Dependency/Modular/IndexConversion.hs +++ b/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -32,14 +32,14 @@ -- resolving these situations. However, the right thing to do is to -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. -convPIs :: OS -> Arch -> CompilerId -> Bool -> Bool -> - SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index -convPIs os arch cid sip strfl iidx sidx = - mkIndex (convIPI' sip iidx ++ convSPI' os arch cid strfl sidx) +convPIs :: OS -> Arch -> CompilerInfo -> Bool -> Bool -> + SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> Index +convPIs os arch comp sip strfl iidx sidx = + mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl sidx) -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. -convIPI' :: Bool -> SI.PackageIndex -> [(PN, I, PInfo)] +convIPI' :: Bool -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] convIPI' sip idx = -- apply shadowing whenever there are multiple installed packages with -- the same version @@ -52,13 +52,13 @@ shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed)) shadow x = x -convIPI :: Bool -> SI.PackageIndex -> Index +convIPI :: Bool -> SI.InstalledPackageIndex -> Index convIPI sip = mkIndex . convIPI' sip -- | Convert a single installed package into the solver-specific format. -convIP :: SI.PackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) +convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = - let ipid = installedPackageId ipi + let ipid = IPI.installedPackageId ipi i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) pn = pkgName (sourcePackageId ipi) in case mapM (convIPId pn idx) (IPI.depends ipi) of @@ -72,7 +72,7 @@ -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored. -convIPId :: PN -> SI.PackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN) +convIPId :: PN -> SI.InstalledPackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN) convIPId pn' idx ipid = case SI.lookupInstalledPackageId idx ipid of Nothing -> Nothing @@ -82,19 +82,19 @@ -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerId -> Bool -> +convSPI' :: OS -> Arch -> CompilerInfo -> Bool -> CI.PackageIndex SourcePackage -> [(PN, I, PInfo)] -convSPI' os arch cid strfl = L.map (convSP os arch cid strfl) . CI.allPackages +convSPI' os arch cinfo strfl = L.map (convSP os arch cinfo strfl) . CI.allPackages -convSPI :: OS -> Arch -> CompilerId -> Bool -> +convSPI :: OS -> Arch -> CompilerInfo -> Bool -> CI.PackageIndex SourcePackage -> Index -convSPI os arch cid strfl = mkIndex . convSPI' os arch cid strfl +convSPI os arch cinfo strfl = mkIndex . convSPI' os arch cinfo strfl -- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerId -> Bool -> SourcePackage -> (PN, I, PInfo) -convSP os arch cid strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = +convSP :: OS -> Arch -> CompilerInfo -> Bool -> SourcePackage -> (PN, I, PInfo) +convSP os arch cinfo strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo - in (pn, i, convGPD os arch cid strfl (PI pn i) gpd) + in (pn, i, convGPD os arch cinfo strfl (PI pn i) gpd) -- We do not use 'flattenPackageDescription' or 'finalizePackageDescription' -- from 'Distribution.PackageDescription.Configuration' here, because we @@ -104,20 +104,20 @@ -- -- TODO: We currently just take all dependencies from all specified library, -- executable and test components. This does not quite seem fair. -convGPD :: OS -> Arch -> CompilerId -> Bool -> +convGPD :: OS -> Arch -> CompilerInfo -> Bool -> PI PN -> GenericPackageDescription -> PInfo -convGPD os arch cid strfl pi +convGPD os arch comp strfl pi (GenericPackageDescription _ flags libs exes tests benchs) = let fds = flagInfo strfl flags in PInfo - (maybe [] (convCondTree os arch cid pi fds (const True) ) libs ++ - concatMap (convCondTree os arch cid pi fds (const True) . snd) exes ++ + (maybe [] (convCondTree os arch comp pi fds (const True) ) libs ++ + concatMap (convCondTree os arch comp pi fds (const True) . snd) exes ++ prefix (Stanza (SN pi TestStanzas)) - (L.map (convCondTree os arch cid pi fds (const True) . snd) tests) ++ + (L.map (convCondTree os arch comp pi fds (const True) . snd) tests) ++ prefix (Stanza (SN pi BenchStanzas)) - (L.map (convCondTree os arch cid pi fds (const True) . snd) benchs)) + (L.map (convCondTree os arch comp pi fds (const True) . snd) benchs)) fds [] -- TODO: add encaps Nothing @@ -132,12 +132,12 @@ flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not (strfl || m)))) -- | Convert condition trees to flagged dependencies. -convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagInfo -> +convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo -> (a -> Bool) -> -- how to detect if a branch is active CondTree ConfVar [Dependency] a -> FlaggedDeps PN -convCondTree os arch cid pi@(PI pn _) fds p (CondNode info ds branches) +convCondTree os arch comp pi@(PI pn _) fds p (CondNode info ds branches) | p info = L.map (D.Simple . convDep pn) ds -- unconditional dependencies - ++ concatMap (convBranch os arch cid pi fds p) branches + ++ concatMap (convBranch os arch comp pi fds p) branches | otherwise = [] -- | Branch interpreter. @@ -148,15 +148,15 @@ -- flags (such as architecture, or compiler flavour). We try to evaluate the -- special flags and subsequently simplify to a tree that only depends on -- simple flag choices. -convBranch :: OS -> Arch -> CompilerId -> +convBranch :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo -> (a -> Bool) -> -- how to detect if a branch is active (Condition ConfVar, CondTree ConfVar [Dependency] a, Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN -convBranch os arch cid@(CompilerId cf cv) pi fds p (c', t', mf') = - go c' ( convCondTree os arch cid pi fds p t') - (maybe [] (convCondTree os arch cid pi fds p) mf') +convBranch os arch cinfo pi fds p (c', t', mf') = + go c' ( convCondTree os arch cinfo pi fds p t') + (maybe [] (convCondTree os arch cinfo pi fds p) mf') where go :: Condition ConfVar -> FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN @@ -172,9 +172,16 @@ go (Var (Arch arch')) t f | arch == arch' = t | otherwise = f - go (Var (Impl cf' cvr')) t f - | cf == cf' && checkVR cvr' cv = t + go (Var (Impl cf cvr)) t f + | matchImpl (compilerInfoId cinfo) || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t | otherwise = f + where + matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv -- If both branches contain the same package as a simple dep, we lift it to -- the next higher-level, but without constraints. This heuristic together diff --git a/Distribution/Client/Dependency/Modular/Message.hs b/Distribution/Client/Dependency/Modular/Message.hs --- a/Distribution/Client/Dependency/Modular/Message.hs +++ b/Distribution/Client/Dependency/Modular/Message.hs @@ -39,20 +39,23 @@ go _ _ [] = [] -- complex patterns go v l (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms - go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (F qfn : v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) - go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (S qsn : v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) - go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (P qpn : v) l ms) + go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) + go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) + go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (add (P qpn) v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (add (P qpn) v) l ms) go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms -- standard display go v l (Enter : ms) = go v (l+1) ms go v l (Leave : ms) = go (drop 1 v) (l-1) ms - go v l (TryP pi@(PI qpn _) : ms) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi) (go (P qpn : v) l ms) - go v l (TryF qfn b : ms) = (atLevel (F qfn : v) l $ "trying: " ++ showQFNBool qfn b) (go (F qfn : v) l ms) - go v l (TryS qsn b : ms) = (atLevel (S qsn : v) l $ "trying: " ++ showQSNBool qsn b) (go (S qsn : v) l ms) - go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (P qpn : v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms) + go v l (TryP pi@(PI qpn _) : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showPI pi) (go (add (P qpn) v) l ms) + go v l (TryF qfn b : ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms) + go v l (TryS qsn b : ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms) + go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (add (P qpn) v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms) go v l (Next _ : ms) = go v l ms -- ignore flag goals in the log go v l (Success : ms) = (atLevel v l $ "done") (go v l ms) go v l (Failure c fr : ms) = (atLevel v l $ "fail" ++ showFR c fr) (go v l ms) + + add :: Var QPN -> [Var QPN] -> [Var QPN] + add v vs = simplifyVar v : vs -- special handler for many subsequent package rejections goPReject :: [Var QPN] -> Int -> QPN -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String] diff --git a/Distribution/Client/Dependency/Modular/PSQ.hs b/Distribution/Client/Dependency/Modular/PSQ.hs --- a/Distribution/Client/Dependency/Modular/PSQ.hs +++ b/Distribution/Client/Dependency/Modular/PSQ.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveFoldable, DeriveTraversable #-} module Distribution.Client.Dependency.Modular.PSQ where -- Priority search queues. @@ -7,7 +8,6 @@ -- (inefficiently implemented) lookup, because I think that queue-based -- operations and sorting turn out to be more efficiency-critical in practice. -import Control.Applicative import Data.Foldable import Data.Function import Data.List as S hiding (foldr) @@ -15,16 +15,7 @@ import Prelude hiding (foldr) newtype PSQ k v = PSQ [(k, v)] - deriving (Eq, Show) - -instance Functor (PSQ k) where - fmap f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs) - -instance Foldable (PSQ k) where - foldr op e (PSQ xs) = foldr op e (fmap snd xs) - -instance Traversable (PSQ k) where - traverse f (PSQ xs) = PSQ <$> traverse (\ (k, v) -> (\ x -> (k, x)) <$> f v) xs + deriving (Eq, Show, Functor, Foldable, Traversable) keys :: PSQ k v -> [k] keys (PSQ xs) = fmap fst xs diff --git a/Distribution/Client/Dependency/Modular/Package.hs b/Distribution/Client/Dependency/Modular/Package.hs --- a/Distribution/Client/Dependency/Modular/Package.hs +++ b/Distribution/Client/Dependency/Modular/Package.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} module Distribution.Client.Dependency.Modular.Package (module Distribution.Client.Dependency.Modular.Package, module Distribution.Package) where @@ -51,7 +52,7 @@ -- | Package instance. A package name and an instance. data PI qpn = PI qpn I - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Functor) -- | String representation of a package instance. showPI :: PI QPN -> String @@ -65,9 +66,6 @@ instI :: I -> Bool instI (I _ (Inst _)) = True instI _ = False - -instance Functor PI where - fmap f (PI x y) = PI (f x) y -- | Package path. (Stored in "reverse" order.) type PP = [PN] diff --git a/Distribution/Client/Dependency/Modular/Preference.hs b/Distribution/Client/Dependency/Modular/Preference.hs --- a/Distribution/Client/Dependency/Modular/Preference.hs +++ b/Distribution/Client/Dependency/Modular/Preference.hs @@ -131,18 +131,19 @@ -- | Transformation that tries to enforce manual flags. Manual flags -- can only be re-set explicitly by the user. This transformation should -- be run after user preferences have been enforced. For manual flags, --- it disables all but the first non-disabled choice. +-- it checks if a user choice has been made. If not, it disables all but +-- the first choice. enforceManualFlags :: Tree QGoalReasonChain -> Tree QGoalReasonChain enforceManualFlags = trav go where go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $ let c = toConflictSet (Goal (F qfn) gr) in case span isDisabled (P.toList ts) of - (xs, []) -> P.fromList xs -- everything's already disabled, leave everything as is - (xs, y : ys) -> P.fromList (xs ++ y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys) + ([], y : ys) -> P.fromList (y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys) + _ -> ts -- something has been manually selected, leave things alone where - isDisabled (_, Fail _ _) = True - isDisabled _ = False + isDisabled (_, Fail _ GlobalConstraintFlag) = True + isDisabled _ = False go x = x -- | Prefer installed packages over non-installed packages, generally. diff --git a/Distribution/Client/Dependency/Modular/Tree.hs b/Distribution/Client/Dependency/Modular/Tree.hs --- a/Distribution/Client/Dependency/Modular/Tree.hs +++ b/Distribution/Client/Dependency/Modular/Tree.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Distribution.Client.Dependency.Modular.Tree where -import Control.Applicative import Control.Monad hiding (mapM) import Data.Foldable import Data.Traversable @@ -20,7 +20,7 @@ | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty | Done RevDepMap | Fail (ConflictSet QPN) FailReason - deriving (Eq, Show) + deriving (Eq, Show, Functor) -- Above, a choice is called trivial if it clearly does not matter. The -- special case of triviality we actually consider is if there are no new -- dependencies introduced by this node. @@ -30,14 +30,6 @@ -- the system, as opposed to flags that are used to explicitly enable or -- disable some functionality. -instance Functor Tree where - fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs) - fmap f (FChoice qfn i b m xs) = FChoice qfn (f i) b m (fmap (fmap f) xs) - fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs) - fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs) - fmap _f (Done rdm ) = Done rdm - fmap _f (Fail cs fr ) = Fail cs fr - data FailReason = InconsistentInitialConstraints | Conflicting [Dep QPN] | CannotInstall @@ -64,6 +56,7 @@ | GoalChoiceF (PSQ OpenGoal b) | DoneF RevDepMap | FailF (ConflictSet QPN) FailReason + deriving (Functor, Foldable, Traversable) out :: Tree a -> TreeF a (Tree a) out (PChoice p i ts) = PChoiceF p i ts @@ -80,30 +73,6 @@ inn (GoalChoiceF ts) = GoalChoice ts inn (DoneF x ) = Done x inn (FailF c x ) = Fail c x - -instance Functor (TreeF a) where - fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts) - fmap f (FChoiceF p i b m ts) = FChoiceF p i b m (fmap f ts) - fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts) - fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts) - fmap _ (DoneF x ) = DoneF x - fmap _ (FailF c x ) = FailF c x - -instance Foldable (TreeF a) where - foldr op e (PChoiceF _ _ ts) = foldr op e ts - foldr op e (FChoiceF _ _ _ _ ts) = foldr op e ts - foldr op e (SChoiceF _ _ _ ts) = foldr op e ts - foldr op e (GoalChoiceF ts) = foldr op e ts - foldr _ e (DoneF _ ) = e - foldr _ e (FailF _ _ ) = e - -instance Traversable (TreeF a) where - traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts - traverse f (FChoiceF p i b m ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> pure m <*> traverse f ts - traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts - traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts - traverse _ (DoneF x ) = DoneF <$> pure x - traverse _ (FailF c x ) = FailF <$> pure c <*> pure x -- | Determines whether a tree is active, i.e., isn't a failure node. active :: Tree a -> Bool diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs --- a/Distribution/Client/Dependency/TopDown.hs +++ b/Distribution/Client/Dependency/TopDown.hs @@ -47,7 +47,7 @@ ( VersionRange, withinRange, simplifyVersionRange , UpperBound(..), asVersionIntervals ) import Distribution.Compiler - ( CompilerId ) + ( CompilerInfo ) import Distribution.System ( Platform ) import Distribution.Simple.Utils @@ -242,9 +242,9 @@ -- the standard 'DependencyResolver' interface. -- topDownResolver :: DependencyResolver -topDownResolver platform comp installedPkgIndex sourcePkgIndex +topDownResolver platform cinfo installedPkgIndex sourcePkgIndex preferences constraints targets = - mapMessages (topDownResolver' platform comp + mapMessages (topDownResolver' platform cinfo (convert installedPkgIndex) sourcePkgIndex preferences constraints targets) where @@ -253,23 +253,23 @@ -- | The native resolver with detailed structured logging and failure types. -- -topDownResolver' :: Platform -> CompilerId +topDownResolver' :: Platform -> CompilerInfo -> PackageIndex InstalledPackage -> PackageIndex SourcePackage -> (PackageName -> PackagePreferences) -> [PackageConstraint] -> [PackageName] -> Progress Log Failure [PlanPackage] -topDownResolver' platform comp installedPkgIndex sourcePkgIndex +topDownResolver' platform cinfo installedPkgIndex sourcePkgIndex preferences constraints targets = fmap (uncurry finalise) . (\cs -> search configure preferences cs initialPkgNames) - =<< pruneBottomUp platform comp + =<< pruneBottomUp platform cinfo =<< addTopLevelConstraints constraints =<< addTopLevelTargets targets emptyConstraintSet where - configure = configurePackage platform comp + configure = configurePackage platform cinfo emptyConstraintSet :: Constraints emptyConstraintSet = Constraints.empty (annotateInstalledPackages topSortNumber installedPkgIndex') @@ -345,7 +345,7 @@ -- | Add exclusion on available packages that cannot be configured. -- -pruneBottomUp :: Platform -> CompilerId +pruneBottomUp :: Platform -> CompilerInfo -> Constraints -> Progress Log Failure Constraints pruneBottomUp platform comp constraints = foldr prune Done (initialPackages constraints) constraints @@ -390,8 +390,8 @@ getSourcePkg (InstalledAndSource _ spkg) = Just spkg -configurePackage :: Platform -> CompilerId -> ConfigurePackage -configurePackage platform comp available spkg = case spkg of +configurePackage :: Platform -> CompilerInfo -> ConfigurePackage +configurePackage platform cinfo available spkg = case spkg of InstalledOnly ipkg -> Right (InstalledOnly ipkg) SourceOnly apkg -> fmap SourceOnly (configure apkg) InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg) @@ -399,7 +399,8 @@ where configure (UnconfiguredPackage apkg@(SourcePackage _ p _ _) _ flags stanzas) = case finalizePackageDescription flags dependencySatisfiable - platform comp [] (enableStanzas stanzas p) of + platform cinfo [] + (enableStanzas stanzas p) of Left missing -> Left missing Right (pkg, flags') -> Right $ SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg) @@ -846,7 +847,7 @@ "applying constraint " ++ display (Dependency pkgname ver) ++ if null pkgids then "" - else "which excludes " ++ listOf display pkgids + else " which excludes " ++ listOf display pkgids showLog (AppliedInstalledConstraint pkgname inst pkgids) = "applying constraint " ++ display pkgname ++ " '" ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' " 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Dependency.Types @@ -19,6 +20,7 @@ AllowNewer(..), isAllowNewer, PackageConstraint(..), + debugPackageConstraint, PackagePreferences(..), InstalledPreference(..), PackagesPreferenceDefault(..), @@ -36,7 +38,7 @@ ( Monoid(..) ) import Distribution.Client.Types - ( OptionalStanza, SourcePackage(..) ) + ( OptionalStanza(..), SourcePackage(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Compat.ReadP @@ -45,21 +47,20 @@ import qualified Distribution.Compat.ReadP as Parse ( pfail, munch1 ) import Distribution.PackageDescription - ( FlagAssignment ) + ( FlagAssignment, FlagName(..) ) import qualified Distribution.Client.PackageIndex as PackageIndex ( PackageIndex ) -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex - ( PackageIndex ) +import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import Distribution.Package ( Dependency, PackageName, InstalledPackageId ) import Distribution.Version - ( VersionRange ) + ( VersionRange, simplifyVersionRange ) import Distribution.Compiler - ( CompilerId ) + ( CompilerInfo ) import Distribution.System ( Platform ) import Distribution.Text - ( Text(..) ) + ( Text(..), display ) import Text.PrettyPrint ( text ) @@ -106,8 +107,8 @@ -- in alternatives. -- type DependencyResolver = Platform - -> CompilerId - -> InstalledPackageIndex.PackageIndex + -> CompilerInfo + -> InstalledPackageIndex -> PackageIndex.PackageIndex SourcePackage -> (PackageName -> PackagePreferences) -> [PackageConstraint] @@ -127,6 +128,27 @@ | PackageConstraintStanzas PackageName [OptionalStanza] deriving (Show,Eq) +-- | Provide a textual representation of a package constraint +-- for debugging purposes. +-- +debugPackageConstraint :: PackageConstraint -> String +debugPackageConstraint (PackageConstraintVersion pn vr) = + display pn ++ " " ++ display (simplifyVersionRange vr) +debugPackageConstraint (PackageConstraintInstalled pn) = + display pn ++ " installed" +debugPackageConstraint (PackageConstraintSource pn) = + display pn ++ " source" +debugPackageConstraint (PackageConstraintFlags pn fs) = + "flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs) + where + showFlag (FlagName f) True = "+" ++ f + showFlag (FlagName f) False = "-" ++ f +debugPackageConstraint (PackageConstraintStanzas pn ss) = + "stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss) + where + showStanza TestStanzas = "test" + showStanza BenchStanzas = "bench" + -- | A per-package preference on the version. It is a soft constraint that the -- 'DependencyResolver' should try to respect where possible. It consists of -- a 'InstalledPreference' which says if we prefer versions of packages @@ -143,6 +165,7 @@ -- version. -- data InstalledPreference = PreferInstalled | PreferLatest + deriving Show -- | Global policy for all packages to say if we prefer package versions that -- are already installed locally or if we just prefer the latest available. @@ -167,6 +190,7 @@ -- * This is the standard policy for install. -- | PreferLatestForSelected + deriving Show -- | Policy for relaxing upper bounds in dependencies. For example, given -- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper @@ -197,6 +221,7 @@ data Progress step fail done = Step step (Progress step fail done) | Fail fail | Done done + deriving Functor -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two -- base cases, one for a final result and one for failure. @@ -211,9 +236,6 @@ where fold (Step s p) = step s (fold p) fold (Fail f) = fail f fold (Done r) = done r - -instance Functor (Progress step fail) where - fmap f = foldProgress Step Fail (Done . f) instance Monad (Progress step fail) where return a = Done a diff --git a/Distribution/Client/Exec.hs b/Distribution/Client/Exec.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Exec.hs @@ -0,0 +1,119 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Exec +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Implementation of the 'exec' command. Runs an arbitrary executable in an +-- environment suitable for making use of the sandbox. +----------------------------------------------------------------------------- + +module Distribution.Client.Exec ( exec + ) where + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS + +import Distribution.Client.Sandbox (getSandboxConfigFilePath) +import Distribution.Client.Sandbox.PackageEnvironment (sandboxPackageDBPath) +import Distribution.Client.Sandbox.Types (UseSandbox (..)) + +import Distribution.Simple.Compiler (Compiler, CompilerFlavor(..), compilerFlavor) +import Distribution.Simple.Program (ghcProgram, ghcjsProgram, lookupProgram) +import Distribution.Simple.Program.Db (ProgramDb, requireProgram, modifyProgramSearchPath) +import Distribution.Simple.Program.Find (ProgramSearchPathEntry(..)) +import Distribution.Simple.Program.Run (programInvocation, runProgramInvocation) +import Distribution.Simple.Program.Types ( simpleProgram, ConfiguredProgram(..) ) +import Distribution.Simple.Utils (die) + +import Distribution.System (Platform) +import Distribution.Verbosity (Verbosity) + +import System.FilePath (searchPathSeparator, ()) +import Control.Applicative ((<$>)) +import Data.Monoid (mempty) + + +-- | Execute the given command in the package's environment. +-- +-- The given command is executed with GHC configured to use the correct +-- package database and with the sandbox bin directory added to the PATH. +exec :: Verbosity + -> UseSandbox + -> Compiler + -> Platform + -> ProgramDb + -> [String] + -> IO () +exec verbosity useSandbox comp platform programDb extraArgs = + case extraArgs of + (exe:args) -> do + program <- requireProgram' verbosity useSandbox programDb exe + env <- ((++) (programOverrideEnv program)) <$> environmentOverrides + let invocation = programInvocation + program { programOverrideEnv = env } + args + runProgramInvocation verbosity invocation + + [] -> die "Please specify an executable to run" + where + environmentOverrides = + case useSandbox of + NoSandbox -> return [] + (UseSandbox sandboxDir) -> + sandboxEnvironment verbosity sandboxDir comp platform programDb + + +-- | Return the package's sandbox environment. +-- +-- The environment sets GHC_PACKAGE_PATH so that GHC will use the sandbox. +sandboxEnvironment :: Verbosity + -> FilePath + -> Compiler + -> Platform + -> ProgramDb + -> IO [(String, Maybe String)] +sandboxEnvironment verbosity sandboxDir comp platform programDb = + case compilerFlavor comp of + GHC -> env GHC.getGlobalPackageDB ghcProgram "GHC_PACKAGE_PATH" + GHCJS -> env GHCJS.getGlobalPackageDB ghcjsProgram "GHCJS_PACKAGE_PATH" + _ -> die "exec only works with GHC and GHCJS" + where + env getGlobalPackageDB hcProgram packagePathEnvVar = do + let Just program = lookupProgram hcProgram programDb + gDb <- getGlobalPackageDB verbosity program + sandboxConfigFilePath <- getSandboxConfigFilePath mempty + let compilerPackagePath = hcPackagePath gDb + return [ (packagePathEnvVar, compilerPackagePath) + , ("CABAL_SANDBOX_PACKAGE_PATH", compilerPackagePath) + , ("CABAL_SANDBOX_CONFIG", Just sandboxConfigFilePath) + ] + + hcPackagePath gDb = + let s = sandboxPackageDBPath sandboxDir comp platform + in Just $ prependToSearchPath gDb s + + prependToSearchPath path newValue = + newValue ++ [searchPathSeparator] ++ path + + +-- | Check that a program is configured and available to be run. If +-- a sandbox is available check in the sandbox's directory. +requireProgram' :: Verbosity + -> UseSandbox + -> ProgramDb + -> String + -> IO ConfiguredProgram +requireProgram' verbosity useSandbox programDb exe = do + (program, _) <- requireProgram + verbosity + (simpleProgram exe) + updateSearchPath + return program + where + updateSearchPath = + flip modifyProgramSearchPath programDb $ \searchPath -> + case useSandbox of + NoSandbox -> searchPath + UseSandbox sandboxDir -> + ProgramSearchPathDir (sandboxDir "bin") : searchPath diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -28,8 +28,8 @@ import Distribution.Package ( packageId ) import Distribution.Simple.Compiler - ( Compiler(compilerId), PackageDBStack ) -import Distribution.Simple.PackageIndex (PackageIndex) + ( Compiler, compilerInfo, PackageDBStack ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program ( ProgramConfiguration ) import Distribution.Simple.Setup @@ -114,7 +114,7 @@ -> Compiler -> Platform -> FetchFlags - -> PackageIndex + -> InstalledPackageIndex -> SourcePackageDb -> [PackageSpecifier SourcePackage] -> IO [SourcePackage] @@ -123,11 +123,11 @@ | includeDependencies = do solver <- chooseSolver verbosity - (fromFlag (fetchSolver fetchFlags)) (compilerId comp) + (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." installPlan <- foldProgress logMsg die return $ resolveDependencies - platform (compilerId comp) + platform (compilerInfo comp) solver resolverParams diff --git a/Distribution/Client/Freeze.hs b/Distribution/Client/Freeze.hs --- a/Distribution/Client/Freeze.hs +++ b/Distribution/Client/Freeze.hs @@ -18,7 +18,7 @@ import Distribution.Client.Config ( SavedConfig(..) ) import Distribution.Client.Types import Distribution.Client.Targets -import Distribution.Client.Dependency hiding ( addConstraints ) +import Distribution.Client.Dependency import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackages, getInstalledPackages ) import Distribution.Client.InstallPlan @@ -35,13 +35,13 @@ import Distribution.Package ( Package, PackageIdentifier, packageId, packageName, packageVersion ) import Distribution.Simple.Compiler - ( Compiler(compilerId), PackageDBStack ) -import Distribution.Simple.PackageIndex (PackageIndex) + ( Compiler, compilerInfo, PackageDBStack ) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Simple.Program ( ProgramConfiguration ) import Distribution.Simple.Setup - ( fromFlag ) + ( fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils ( die, notice, debug, writeFileAtomic ) import Distribution.System @@ -120,7 +120,7 @@ -> Platform -> Maybe SandboxPackageInfo -> FreezeFlags - -> PackageIndex + -> InstalledPackageIndex -> SourcePackageDb -> [PackageSpecifier SourcePackage] -> IO [PlanPackage] @@ -128,12 +128,12 @@ installedPkgIndex sourcePkgDb pkgSpecifiers = do solver <- chooseSolver verbosity - (fromFlag (freezeSolver freezeFlags)) (compilerId comp) + (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp) notice verbosity "Resolving dependencies..." installPlan <- foldProgress logMsg die return $ resolveDependencies - platform (compilerId comp) + platform (compilerInfo comp) solver resolverParams @@ -155,12 +155,23 @@ . setStrongFlags strongFlags + . addConstraints + [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas + | pkgSpecifier <- pkgSpecifiers ] + . maybe id applySandboxInstallPolicy mSandboxPkgInfo $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers logMsg message rest = debug verbosity message >> rest + stanzas = concat + [ if testsEnabled then [TestStanzas] else [] + , if benchmarksEnabled then [BenchStanzas] else [] + ] + testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags + benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags + reorderGoals = fromFlag (freezeReorderGoals freezeFlags) independentGoals = fromFlag (freezeIndependentGoals freezeFlags) shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) @@ -196,10 +207,11 @@ freezePackages :: Package pkg => Verbosity -> [pkg] -> IO () freezePackages verbosity pkgs = do - pkgEnv <- fmap (createPkgEnv . addConstraints) $ loadUserConfig verbosity "" + pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $ + loadUserConfig verbosity "" writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv where - addConstraints config = + addFrozenConstraints config = config { savedConfigureExFlags = (savedConfigureExFlags config) { configExConstraints = constraints pkgs diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs --- a/Distribution/Client/Haddock.hs +++ b/Distribution/Client/Haddock.hs @@ -27,14 +27,14 @@ import Distribution.Version (Version(Version), orLaterVersion) import Distribution.Verbosity (Verbosity) import Distribution.Simple.PackageIndex - ( PackageIndex, allPackagesByName ) + ( InstalledPackageIndex, allPackagesByName ) import Distribution.Simple.Utils ( comparing, debug, installDirectoryContents, withTempDirectory ) import Distribution.InstalledPackageInfo as InstalledPackageInfo ( InstalledPackageInfo_(exposed) ) regenerateHaddockIndex :: Verbosity - -> PackageIndex -> ProgramConfiguration -> FilePath + -> InstalledPackageIndex -> ProgramConfiguration -> FilePath -> IO () regenerateHaddockIndex verbosity pkgs conf index = do (paths, warns) <- haddockPackagePaths pkgs' Nothing diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -17,8 +17,8 @@ import Network.URI ( URI (..), URIAuth (..) ) import Network.Browser - ( BrowserAction, browse, setAllowBasicAuth, setAuthorityGen - , setOutHandler, setErrHandler, setProxy, request) + ( BrowserAction, browse + , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request) import Network.Stream ( Result, ConnError(..) ) import Control.Monad @@ -80,10 +80,10 @@ -> Maybe String -- ^ Optional etag to check if we already have the latest file. -> IO (Result (Response ByteString)) getHTTP verbosity uri etag = liftM (\(_, resp) -> Right resp) $ - cabalBrowse verbosity Nothing (request (mkRequest uri etag)) + cabalBrowse verbosity (return ()) (request (mkRequest uri etag)) cabalBrowse :: Verbosity - -> Maybe (String, String) + -> BrowserAction s () -> BrowserAction s a -> IO a cabalBrowse verbosity auth act = do @@ -92,8 +92,8 @@ setProxy p setErrHandler (warn verbosity . ("http error: "++)) setOutHandler (debug verbosity) - setAllowBasicAuth False - setAuthorityGen (\_ _ -> return auth) + auth + setAuthorityGen (\_ _ -> return Nothing) act downloadURI :: Verbosity diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -11,6 +11,7 @@ -- Extra utils related to the package indexes. ----------------------------------------------------------------------------- module Distribution.Client.IndexUtils ( + getIndexFileAge, getInstalledPackages, getSourcePackages, getSourcePackagesStrict, @@ -20,6 +21,7 @@ parsePackageIndex, readRepoIndex, updateRepoIndexCache, + updatePackageIndexCacheFile, BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType ) where @@ -33,6 +35,7 @@ , Dependency(Dependency), InstalledPackageId(..) ) import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse @@ -55,7 +58,7 @@ import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils - ( die, warn, info, fromUTF8, tryFindPackageDesc ) + ( die, warn, info, fromUTF8 ) import Data.Char (isAlphaNum) import Data.Maybe (mapMaybe, fromMaybe) @@ -69,7 +72,8 @@ import qualified Data.ByteString.Char8 as BSS import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress) -import Distribution.Client.Utils (byteStringToFilePath) +import Distribution.Client.Utils ( byteStringToFilePath + , tryFindAddSourcePackageDesc ) import Distribution.Compat.Exception (catchIO) import Distribution.Client.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist) @@ -79,18 +83,19 @@ import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) +import Numeric (showFFloat) getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration - -> IO InstalledPackageIndex.PackageIndex + -> IO InstalledPackageIndex getInstalledPackages verbosity comp packageDbs conf = Configure.getInstalledPackages verbosity' comp packageDbs conf where --FIXME: make getInstalledPackages use sensible verbosity in the first place verbosity' = lessVerbose verbosity -convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage +convert :: InstalledPackageIndex -> PackageIndex InstalledPackage convert index' = PackageIndex.fromList -- There can be multiple installed instances of each package version, -- like when the same package is installed in the global & user DBs. @@ -178,10 +183,9 @@ let indexFile = repoLocalDir repo "00-index.tar" cacheFile = repoLocalDir repo "00-index.cache" in handleNotFound $ do - warnIfIndexIsOld indexFile + warnIfIndexIsOld =<< getIndexFileAge repo whenCacheOutOfDate indexFile cacheFile $ do - info verbosity "Updating the index cache file..." - updatePackageIndexCacheFile indexFile cacheFile + updatePackageIndexCacheFile verbosity indexFile cacheFile readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile mode where @@ -212,23 +216,27 @@ else ioError e isOldThreshold = 15 --days - warnIfIndexIsOld indexFile = do - dt <- getFileAge indexFile + warnIfIndexIsOld dt = do when (dt >= isOldThreshold) $ case repoKind repo of Left remoteRepo -> warn verbosity $ "The package list for '" ++ remoteRepoName remoteRepo - ++ "' is " ++ show dt ++ " days old.\nRun " + ++ "' is " ++ showFFloat (Just 1) dt " days old.\nRun " ++ "'cabal update' to get the latest list of available packages." Right _localRepo -> return () + +-- | Return the age of the index file in days (as a Double). +getIndexFileAge :: Repo -> IO Double +getIndexFileAge repo = getFileAge $ repoLocalDir repo "00-index.tar" + + -- | It is not necessary to call this, as the cache will be updated when the -- index is read normally. However you can do the work earlier if you like. -- updateRepoIndexCache :: Verbosity -> Repo -> IO () updateRepoIndexCache verbosity repo = whenCacheOutOfDate indexFile cacheFile $ do - info verbosity "Updating the index cache file..." - updatePackageIndexCacheFile indexFile cacheFile + updatePackageIndexCacheFile verbosity indexFile cacheFile where indexFile = repoLocalDir repo "00-index.tar" cacheFile = repoLocalDir repo "00-index.cache" @@ -241,7 +249,7 @@ else do origTime <- getModTime origFile cacheTime <- getModTime cacheFile - when (origTime >= cacheTime) action + when (origTime > cacheTime) action ------------------------------------------------------------------------ -- Reading the index file @@ -351,7 +359,8 @@ | Tar.isBuildTreeRefTypeCode typeCode -> Just $ do let path = byteStringToFilePath content - cabalFile <- tryFindPackageDesc path + err = "Error reading package index." + cabalFile <- tryFindAddSourcePackageDesc path err descr <- PackageDesc.Parse.readPackageDescription normal cabalFile return $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr) descr path blockNo @@ -378,8 +387,9 @@ -- Reading and updating the index cache -- -updatePackageIndexCacheFile :: FilePath -> FilePath -> IO () -updatePackageIndexCacheFile indexFile cacheFile = do +updatePackageIndexCacheFile :: Verbosity -> FilePath -> FilePath -> IO () +updatePackageIndexCacheFile verbosity indexFile cacheFile = do + info verbosity "Updating the index cache file..." (mkPkgs, prefs) <- either fail return . parsePackageIndex . maybeDecompress @@ -452,8 +462,9 @@ -- package id for build tree references - the user might edit the .cabal -- file after the reference was added to the index. path <- liftM byteStringToFilePath . getEntryContent $ blockno - pkg <- do cabalFile <- tryFindPackageDesc path - PackageDesc.Parse.readPackageDescription normal cabalFile + pkg <- do let err = "Error reading package index from cache." + file <- tryFindAddSourcePackageDesc path err + PackageDesc.Parse.readPackageDescription normal file let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno) accum (srcpkg:srcpkgs) prefs entries @@ -503,31 +514,32 @@ | CachePreference Dependency deriving (Eq) +packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String +packageKey = "pkg:" +blocknoKey = "b#" +buildTreeRefKey = "build-tree-ref:" +preferredVersionKey = "pref-ver:" + readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry readIndexCacheEntry = \line -> case BSS.words line of [key, pkgnamestr, pkgverstr, sep, blocknostr] - | key == packageKey && sep == blocknoKey -> + | key == BSS.pack packageKey && sep == BSS.pack blocknoKey -> case (parseName pkgnamestr, parseVer pkgverstr [], parseBlockNo blocknostr) of (Just pkgname, Just pkgver, Just blockno) -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno) _ -> Nothing - [key, typecodestr, blocknostr] | key == buildTreeRefKey -> + [key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey -> case (parseRefType typecodestr, parseBlockNo blocknostr) of (Just refType, Just blockno) -> Just (CacheBuildTreeRef refType blockno) _ -> Nothing - (key: remainder) | key == preferredVersionKey -> + (key: remainder) | key == BSS.pack preferredVersionKey -> fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder))) _ -> Nothing where - packageKey = BSS.pack "pkg:" - blocknoKey = BSS.pack "b#" - buildTreeRefKey = BSS.pack "build-tree-ref:" - preferredVersionKey = BSS.pack "pref-ver:" - parseName str | BSS.all (\c -> isAlphaNum c || c == '-') str = Just (PackageName (BSS.unpack str)) @@ -554,13 +566,20 @@ _ -> Nothing showIndexCacheEntry :: IndexCacheEntry -> String -showIndexCacheEntry entry = case entry of - CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid) - ++ " " ++ display (packageVersion pkgid) - ++ " b# " ++ show b - CacheBuildTreeRef t b -> "build-tree-ref: " ++ (typeCodeFromRefType t:" ") - ++ show b - CachePreference dep -> "pref-ver: " ++ display dep +showIndexCacheEntry entry = unwords $ case entry of + CachePackageId pkgid b -> [ packageKey + , display (packageName pkgid) + , display (packageVersion pkgid) + , blocknoKey + , show b + ] + CacheBuildTreeRef t b -> [ buildTreeRefKey + , [typeCodeFromRefType t] + , show b + ] + CachePreference dep -> [ preferredVersionKey + , display dep + ] readIndexCache :: BSS.ByteString -> [IndexCacheEntry] readIndexCache = mapMaybe readIndexCacheEntry . BSS.lines diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -25,7 +25,7 @@ ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile - , getDirectoryContents ) + , getDirectoryContents, createDirectoryIfMissing ) import System.FilePath ( (), (<.>), takeBaseName ) import Data.Time @@ -45,7 +45,7 @@ import Control.Applicative ( (<$>) ) import Control.Monad - ( when, unless, (>=>), join ) + ( when, unless, (>=>), join, forM_ ) import Control.Arrow ( (&&&), (***) ) @@ -67,7 +67,7 @@ import Distribution.Client.Init.Types ( InitFlags(..), PackageType(..), Category(..) ) import Distribution.Client.Init.Licenses - ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20 ) + ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc ) import Distribution.Client.Init.Heuristics ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates, SourceFileEntry(..), @@ -87,7 +87,7 @@ import Distribution.Simple.Program ( ProgramConfiguration ) import Distribution.Simple.PackageIndex - ( PackageIndex, moduleNameIndex ) + ( InstalledPackageIndex, moduleNameIndex ) import Distribution.Text ( display, Text(..) ) @@ -107,6 +107,7 @@ writeLicense initFlags' writeSetupFile initFlags' + createSourceDirectories initFlags' success <- writeCabalFile initFlags' when success $ generateWarnings initFlags' @@ -117,7 +118,7 @@ -- | Fill in more details by guessing, discovering, or prompting the -- user. -extendFlags :: PackageIndex -> InitFlags -> IO InitFlags +extendFlags :: InstalledPackageIndex -> InitFlags -> IO InitFlags extendFlags pkgIx = getPackageName >=> getVersion @@ -164,7 +165,7 @@ -- if possible. getVersion :: InitFlags -> IO InitFlags getVersion flags = do - let v = Just $ Version { versionBranch = [0,1,0,0], versionTags = [] } + let v = Just $ Version [0,1,0,0] [] v' <- return (flagToMaybe $ version flags) ?>> maybePrompt flags (prompt "Package version" v) ?>> return v @@ -313,27 +314,30 @@ where promptMsg = "Include documentation on what each field means (y/n)" --- | Try to guess the source root directory (don't prompt the user). +-- | Ask for the source root directory. getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do - srcDirs <- return (sourceDirs flags) - ?>> Just `fmap` guessSourceDirs flags + srcDirs <- return (sourceDirs flags) + ?>> fmap (:[]) `fmap` guessSourceDir flags + ?>> fmap (fmap ((:[]) . either id id) . join) (maybePrompt + flags + (promptListOptional' "Source directory" ["src"] id)) return $ flags { sourceDirs = srcDirs } --- | Try to guess source directories. Could try harder; for the +-- | Try to guess source directory. Could try harder; for the -- moment just looks to see whether there is a directory called 'src'. -guessSourceDirs :: InitFlags -> IO [String] -guessSourceDirs flags = do +guessSourceDir :: InitFlags -> IO (Maybe String) +guessSourceDir flags = do dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags srcIsDir <- doesDirectoryExist (dir "src") - if srcIsDir - then return ["src"] - else return [] + return $ if srcIsDir + then Just "src" + else Nothing -- | Get the list of exposed modules and extra tools needed to build them. -getModulesBuildToolsAndDeps :: PackageIndex -> InitFlags -> IO InitFlags +getModulesBuildToolsAndDeps :: InstalledPackageIndex -> InitFlags -> IO InitFlags getModulesBuildToolsAndDeps pkgIx flags = do dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags @@ -367,7 +371,7 @@ , otherExts = exts } -importsToDeps :: InitFlags -> [ModuleName] -> PackageIndex -> IO [P.Dependency] +importsToDeps :: InitFlags -> [ModuleName] -> InstalledPackageIndex -> IO [P.Dependency] importsToDeps flags mods pkgIx = do let modMap :: M.Map ModuleName [InstalledPackageInfo] @@ -498,10 +502,17 @@ => String -- ^ prompt -> [t] -- ^ choices -> IO (Maybe (Either String t)) -promptListOptional pr choices = +promptListOptional pr choices = promptListOptional' pr choices display + +promptListOptional' :: Eq t + => String -- ^ prompt + -> [t] -- ^ choices + -> (t -> String) -- ^ show an item + -> IO (Maybe (Either String t)) +promptListOptional' pr choices displayItem = fmap rearrange $ promptList pr (Nothing : map Just choices) (Just Nothing) - (maybe "(none)" display) True + (maybe "(none)" displayItem) True where rearrange = either (Just . Left) (fmap Right) @@ -589,6 +600,9 @@ Flag (MPL (Version {versionBranch = [2, 0]})) -> Just mpl20 + Flag ISC + -> Just $ isc authors year + _ -> Nothing case licenseFile of @@ -629,6 +643,12 @@ writeFileSafe flags fileName content = do moveExistingFile flags fileName writeFile fileName content + +-- | Create source directories, if they were given. +createSourceDirectories :: InitFlags -> IO () +createSourceDirectories flags = case sourceDirs flags of + Just dirs -> forM_ dirs (createDirectoryIfMissing True) + Nothing -> return () -- | Move an existing file, if there is one, and the overwrite flag is -- not set. diff --git a/Distribution/Client/Init/Licenses.hs b/Distribution/Client/Init/Licenses.hs --- a/Distribution/Client/Init/Licenses.hs +++ b/Distribution/Client/Init/Licenses.hs @@ -10,7 +10,7 @@ , apache20 , mit , mpl20 - + , isc ) where type License = String @@ -3045,4 +3045,21 @@ , "" , " This Source Code Form is \"Incompatible With Secondary Licenses\", as" , " defined by the Mozilla Public License, v. 2.0." + ] + +isc :: String -> String -> License +isc authors year = unlines + [ "Copyright (c) " ++ year ++ " " ++ authors + , "" + , "Permission to use, copy, modify, and/or distribute this software for any purpose" + , "with or without fee is hereby granted, provided that the above copyright notice" + , "and this permission notice appear in all copies." + , "" + , "THE SOFTWARE IS PROVIDED \"AS IS\" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH" + , "REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND" + , "FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT," + , "INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS" + , "OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER" + , "TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF" + , "THIS SOFTWARE." ] diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Install @@ -29,10 +30,10 @@ ) where import Data.List - ( unfoldr, nub, sort, (\\) ) + ( isPrefixOf, unfoldr, nub, sort, (\\) ) import qualified Data.Set as S import Data.Maybe - ( isJust, fromMaybe, maybeToList ) + ( isJust, fromMaybe, mapMaybe, maybeToList ) import Control.Exception as Exception ( Exception(toException), bracket, catches , Handler(Handler), handleJust, IOException, SomeException ) @@ -44,13 +45,15 @@ ( ExitCode(..) ) import Distribution.Compat.Exception ( catchIO, catchExit ) +import Control.Applicative + ( (<$>) ) import Control.Monad - ( when, unless ) + ( forM_, when, unless ) import System.Directory ( getTemporaryDirectory, doesDirectoryExist, doesFileExist, createDirectoryIfMissing, removeFile, renameDirectory ) import System.FilePath - ( (), (<.>), takeDirectory ) + ( (), (<.>), equalFilePath, takeDirectory ) import System.IO ( openFile, IOMode(AppendMode), hClose ) import System.IO.Error @@ -87,7 +90,7 @@ ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import qualified Distribution.Client.BuildReports.Anonymous as BuildReports import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeAnonymous, storeLocal, fromInstallPlan ) + ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) import qualified Distribution.Client.InstallSymlink as InstallSymlink ( symlinkBinaries ) import qualified Distribution.Client.PackageIndex as SourcePackageIndex @@ -97,14 +100,15 @@ import Distribution.Client.Compat.ExecutablePath import Distribution.Client.JobControl +import Distribution.Utils.NubList import Distribution.Simple.Compiler ( CompilerId(..), Compiler(compilerId), compilerFlavor - , PackageDB(..), PackageDBStack ) + , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Setup ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags @@ -121,9 +125,9 @@ ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv ) import Distribution.Package - ( PackageIdentifier, PackageId, packageName, packageVersion - , Package(..), PackageFixedDeps(..) - , Dependency(..), thisPackageVersion, InstalledPackageId ) + ( PackageIdentifier(..), PackageId, packageName, packageVersion + , Package(..), PackageFixedDeps(..), PackageKey + , Dependency(..), thisPackageVersion, InstalledPackageId, installedPackageId ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription ( PackageDescription, GenericPackageDescription(..), Flag(..) @@ -133,7 +137,7 @@ import Distribution.ParseUtils ( showPWarning ) import Distribution.Version - ( Version ) + ( Version, VersionRange, foldVersionRange ) import Distribution.Simple.Utils as Utils ( notice, info, warn, debug, debugNoWrap, die , intercalate, withTempDirectory ) @@ -187,10 +191,15 @@ userTargets0 = do installContext <- makeInstallContext verbosity args (Just userTargets0) - installPlan <- foldProgress logMsg die' return =<< + planResult <- foldProgress logMsg (return . Left) (return . Right) =<< makeInstallPlan verbosity args installContext - processInstallPlan verbosity args installContext installPlan + case planResult of + Left message -> do + reportPlanningFailure verbosity args installContext message + die' message + Right installPlan -> + processInstallPlan verbosity args installContext installPlan where args :: InstallArgs args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo, @@ -209,7 +218,7 @@ -- TODO: Make InstallContext a proper data type with documented fields. -- | Common context for makeInstallPlan and processInstallPlan. -type InstallContext = ( PackageIndex, SourcePackageDb +type InstallContext = ( InstalledPackageIndex, SourcePackageDb , [UserTarget], [PackageSpecifier SourcePackage] ) -- TODO: Make InstallArgs a proper data type with documented fields or just get @@ -269,7 +278,7 @@ _, pkgSpecifiers) = do solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) - (compilerId comp) + (compilerInfo comp) notice verbosity "Resolving dependencies..." return $ planPackages comp platform mSandboxPkgInfo solver configFlags configExFlags installFlags @@ -280,10 +289,10 @@ -> InstallPlan -> IO () processInstallPlan verbosity - args@(_,_, _, _, _, _, _, _, _, _, installFlags, _) + args@(_,_, comp, _, _, _, _, _, _, _, installFlags, _) (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers) installPlan = do - checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb + checkPrintPlan verbosity comp installedPkgIndex installPlan sourcePkgDb installFlags pkgSpecifiers unless (dryRun || nothingToInstall) $ do @@ -305,7 +314,7 @@ -> ConfigFlags -> ConfigExFlags -> InstallFlags - -> PackageIndex + -> InstalledPackageIndex -> SourcePackageDb -> [PackageSpecifier SourcePackage] -> Progress String String InstallPlan @@ -314,7 +323,7 @@ installedPkgIndex sourcePkgDb pkgSpecifiers = resolveDependencies - platform (compilerId comp) + platform (compilerInfo comp) solver resolverParams @@ -422,13 +431,14 @@ -- | Perform post-solver checks of the install plan and print it if -- either requested or needed. checkPrintPlan :: Verbosity - -> PackageIndex + -> Compiler + -> InstalledPackageIndex -> InstallPlan -> SourcePackageDb -> InstallFlags -> [PackageSpecifier SourcePackage] -> IO () -checkPrintPlan verbosity installed installPlan sourcePkgDb +checkPrintPlan verbosity comp installed installPlan sourcePkgDb installFlags pkgSpecifiers = do -- User targets that are already installed. @@ -445,7 +455,7 @@ : map (display . packageId) preExistingTargets ++ ["Use --reinstall if you want to reinstall anyway."] - let lPlan = linearizeInstallPlan installed installPlan + let lPlan = linearizeInstallPlan comp installed installPlan -- Are any packages classified as reinstalls? let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan -- Packages that are already broken. @@ -497,25 +507,29 @@ dryRun = fromFlag (installDryRun installFlags) overrideReinstall = fromFlag (installOverrideReinstall installFlags) -linearizeInstallPlan :: PackageIndex +linearizeInstallPlan :: Compiler + -> InstalledPackageIndex -> InstallPlan -> [(ReadyPackage, PackageStatus)] -linearizeInstallPlan installedPkgIndex plan = +linearizeInstallPlan comp installedPkgIndex plan = unfoldr next plan where next plan' = case InstallPlan.ready plan' of [] -> Nothing (pkg:_) -> Just ((pkg, status), plan'') where - pkgid = packageId pkg - status = packageStatus installedPkgIndex pkg + pkgid = installedPackageId pkg + status = packageStatus comp installedPkgIndex pkg plan'' = InstallPlan.completed pkgid (BuildOk DocsNotTried TestsNotTried (Just $ Installed.emptyInstalledPackageInfo - { Installed.sourcePackageId = pkgid })) + { Installed.sourcePackageId = packageId pkg + , Installed.installedPackageId = pkgid })) (InstallPlan.processing [pkg] plan') --FIXME: This is a bit of a hack, -- pretending that each package is installed + -- It's doubly a hack because the installed package ID + -- didn't get updated... data PackageStatus = NewPackage | NewVersion [Version] @@ -527,12 +541,12 @@ extractReinstalls (Reinstall ipids _) = ipids extractReinstalls _ = [] -packageStatus :: PackageIndex -> ReadyPackage -> PackageStatus -packageStatus installedPkgIndex cpkg = +packageStatus :: Compiler -> InstalledPackageIndex -> ReadyPackage -> PackageStatus +packageStatus _comp installedPkgIndex cpkg = case PackageIndex.lookupPackageName installedPkgIndex (packageName cpkg) of [] -> NewPackage - ps -> case filter ((==packageId cpkg) + ps -> case filter ((== packageId cpkg) . Installed.sourcePackageId) (concatMap snd ps) of [] -> NewVersion (map fst ps) pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs) @@ -594,12 +608,11 @@ showLatest :: ReadyPackage -> String showLatest pkg = case mLatestVersion of Just latestVersion -> - if pkgVersion < latestVersion + if packageVersion pkg < latestVersion then (" (latest: " ++ display latestVersion ++ ")") else "" Nothing -> "" where - pkgVersion = packageVersion pkg mLatestVersion :: Maybe Version mLatestVersion = case SourcePackageIndex.lookupPackageName (packageIndex sourcePkgDb) @@ -641,6 +654,71 @@ -- * Post installation stuff -- ------------------------------------------------------------ +-- | Report a solver failure. This works slightly differently to +-- 'postInstallActions', as (by definition) we don't have an install plan. +reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String -> IO () +reportPlanningFailure verbosity + (_, _, comp, platform, _, _, _ + ,_, configFlags, _, installFlags, _) + (_, sourcePkgDb, _, pkgSpecifiers) + message = do + + when reportFailure $ do + + -- Only create reports for explicitly named packages + let pkgids = + filter (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $ + mapMaybe theSpecifiedPackage pkgSpecifiers + + buildReports = BuildReports.fromPlanningFailure platform (compilerId comp) + pkgids (configConfigurationsFlags configFlags) + + when (not (null buildReports)) $ + info verbosity $ + "Solver failure will be reported for " + ++ intercalate "," (map display pkgids) + + -- Save reports + BuildReports.storeLocal (compilerInfo comp) + (fromNubList $ installSummaryFile installFlags) buildReports platform + + -- Save solver log + case logFile of + Nothing -> return () + Just template -> forM_ pkgids $ \pkgid -> + let env = initialPathTemplateEnv pkgid dummyPackageKey + (compilerInfo comp) platform + path = fromPathTemplate $ substPathTemplate env template + in writeFile path message + + where + reportFailure = fromFlag (installReportPlanningFailure installFlags) + logFile = flagToMaybe (installLogFile installFlags) + + -- A PackageKey is calculated from the transitive closure of + -- dependencies, but when the solver fails we don't have that. + -- So we fail. + dummyPackageKey = error "reportPlanningFailure: package key not available" + +-- | If a 'PackageSpecifier' refers to a single package, return Just that package. +theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId +theSpecifiedPackage pkgSpec = + case pkgSpec of + NamedPackage name [PackageConstraintVersion name' version] + | name == name' -> PackageIdentifier name <$> trivialRange version + NamedPackage _ _ -> Nothing + SpecificSourcePackage pkg -> Just $ packageId pkg + where + -- | If a range includes only a single version, return Just that version. + trivialRange :: VersionRange -> Maybe Version + trivialRange = foldVersionRange + Nothing + Just -- "== v" + (\_ -> Nothing) + (\_ -> Nothing) + (\_ _ -> Nothing) + (\_ _ -> Nothing) + -- | Various stuff we do after successful or unsuccessfully installing a bunch -- of packages. This includes: -- @@ -667,17 +745,17 @@ | UserTargetNamed dep <- targets ] let buildReports = BuildReports.fromInstallPlan installPlan - BuildReports.storeLocal (installSummaryFile installFlags) buildReports + BuildReports.storeLocal (compilerInfo comp) (fromNubList $ installSummaryFile installFlags) buildReports (InstallPlan.planPlatform installPlan) when (reportingLevel >= AnonymousReports) $ BuildReports.storeAnonymous buildReports when (reportingLevel == DetailedReports) $ storeDetailedBuildReports verbosity logsDir buildReports - regenerateHaddockIndex verbosity packageDBs comp platform conf + regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox configFlags installFlags installPlan - symlinkBinaries verbosity configFlags installFlags installPlan + symlinkBinaries verbosity comp configFlags installFlags installPlan printBuildFailures installPlan @@ -691,7 +769,7 @@ worldFile = fromFlag $ globalWorldFile globalFlags storeDetailedBuildReports :: Verbosity -> FilePath - -> [(BuildReports.BuildReport, Repo)] -> IO () + -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () storeDetailedBuildReports verbosity logsDir reports = sequence_ [ do dotCabal <- defaultCabalDir let logFileName = display (BuildReports.package report) <.> "log" @@ -704,7 +782,7 @@ createDirectoryIfMissing True reportsDir -- FIXME writeFile reportFile (show (BuildReports.show report, buildLog)) - | (report, Repo { repoKind = Left remoteRepo }) <- reports + | (report, Just Repo { repoKind = Left remoteRepo }) <- reports , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] where @@ -728,11 +806,12 @@ -> Compiler -> Platform -> ProgramConfiguration + -> UseSandbox -> ConfigFlags -> InstallFlags -> InstallPlan -> IO () -regenerateHaddockIndex verbosity packageDBs comp platform conf +regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox configFlags installFlags installPlan | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do @@ -757,9 +836,10 @@ && isJust (flagToMaybe (installHaddockIndex installFlags)) -- We want to regenerate the index if some new documentation was actually - -- installed. Since the index is per-user, we don't do it for global - -- installs or special cases where we're installing into a specific db. - shouldRegenerateHaddockIndex = normalUserInstall + -- installed. Since the index can be only per-user or per-sandbox (see + -- #1337), we don't do it for global installs or special cases where we're + -- installing into a specific db. + shouldRegenerateHaddockIndex = (isUseSandbox useSandbox || normalUserInstall) && someDocsWereInstalled installPlan where someDocsWereInstalled = any installedDocs . InstallPlan.toList @@ -767,7 +847,7 @@ && all (not . isSpecificPackageDB) packageDBs installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True - installedDocs _ = False + installedDocs _ = False isSpecificPackageDB (SpecificPackageDB _) = True isSpecificPackageDB _ = False @@ -775,8 +855,9 @@ . substPathTemplate env where env = env0 ++ installDirsTemplateEnv absoluteDirs - env0 = InstallDirs.compilerTemplateEnv (compilerId comp) + env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp) ++ InstallDirs.platformTemplateEnv platform + ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform absoluteDirs = InstallDirs.substituteInstallDirTemplates env0 templateDirs templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault @@ -784,11 +865,12 @@ symlinkBinaries :: Verbosity + -> Compiler -> ConfigFlags -> InstallFlags -> InstallPlan -> IO () -symlinkBinaries verbosity configFlags installFlags plan = do - failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan +symlinkBinaries verbosity comp configFlags installFlags plan = do + failed <- InstallSymlink.symlinkBinaries comp configFlags installFlags plan case failed of [] -> return () [(_, exe, path)] -> @@ -836,12 +918,16 @@ InstallFailed e -> " failed during the final install step." ++ showException e + -- This will never happen, but we include it for completeness + PlanningFailed -> " failed during the planning phase." + showException e = " The exception was:\n " ++ show e ++ maybeOOM e #ifdef mingw32_HOST_OS maybeOOM _ = "" #else maybeOOM e = maybe "" onExitFailure (fromException e) - onExitFailure (ExitFailure 9) = + onExitFailure (ExitFailure n) + | n == 9 || n == -9 = "\nThis may be due to an out-of-memory condition." onExitFailure _ = "" #endif @@ -877,11 +963,11 @@ -- | If logging is enabled, contains location of the log file and the verbosity -- level for logging. -type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity) +type UseLogFile = Maybe (PackageIdentifier -> PackageKey -> FilePath, Verbosity) performInstallations :: Verbosity -> InstallArgs - -> PackageIndex + -> InstalledPackageIndex -> InstallPlan -> IO InstallPlan performInstallations verbosity @@ -902,20 +988,23 @@ installLock <- newLock -- serialise installation cacheLock <- newLock -- serialise access to setup exe cache - executeInstallPlan verbosity jobControl useLogFile installPlan $ \rpkg -> - installReadyPackage platform compid configFlags + + executeInstallPlan verbosity comp jobControl useLogFile installPlan $ \rpkg -> + -- Calculate the package key (ToDo: Is this right for source install) + let pkg_key = readyPackageKey comp rpkg in + installReadyPackage platform cinfo configFlags rpkg $ \configFlags' src pkg pkgoverride -> fetchSourcePackage verbosity fetchLimit src $ \src' -> installLocalPackage verbosity buildLimit (packageId pkg) src' distPref $ \mpath -> - installUnpackedPackage verbosity buildLimit installLock numJobs + installUnpackedPackage verbosity buildLimit installLock numJobs pkg_key (setupScriptOptions installedPkgIndex cacheLock) miscOptions configFlags' installFlags haddockFlags - compid platform pkg pkgoverride mpath useLogFile + cinfo platform pkg pkgoverride mpath useLogFile where platform = InstallPlan.planPlatform installPlan - compid = InstallPlan.planCompiler installPlan + cinfo = InstallPlan.planCompiler installPlan numJobs = determineNumJobs (installNumJobs installFlags) numFetchJobs = 2 @@ -945,6 +1034,7 @@ useLoggingHandle = Nothing, useWorkingDir = Nothing, forceExternalSetupMethod = parallelInstall, + useWin32CleanHack = False, setupCacheLock = Just lock } reportingLevel = fromFlag (installBuildReports installFlags) @@ -987,12 +1077,12 @@ | parallelInstall = False | otherwise = False - substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath - substLogFileName template pkg = fromPathTemplate - . substPathTemplate env - $ template - where env = initialPathTemplateEnv (packageId pkg) - (compilerId comp) platform + substLogFileName :: PathTemplate -> PackageIdentifier -> PackageKey -> FilePath + substLogFileName template pkg pkg_key = fromPathTemplate + . substPathTemplate env + $ template + where env = initialPathTemplateEnv (packageId pkg) pkg_key + (compilerInfo comp) platform miscOptions = InstallMisc { rootCmd = if fromFlag (configUserInstall configFlags) @@ -1005,12 +1095,13 @@ executeInstallPlan :: Verbosity - -> JobControl IO (PackageId, BuildResult) + -> Compiler + -> JobControl IO (PackageId, PackageKey, BuildResult) -> UseLogFile -> InstallPlan -> (ReadyPackage -> IO BuildResult) -> IO InstallPlan -executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg = +executeInstallPlan verbosity comp jobCtl useLogFile plan0 installPkg = tryNewTasks 0 plan0 where tryNewTasks taskCount plan = do @@ -1022,9 +1113,10 @@ [ do info verbosity $ "Ready to install " ++ display pkgid spawnJob jobCtl $ do buildResult <- installPkg pkg - return (packageId pkg, buildResult) + return (packageId pkg, pkg_key, buildResult) | pkg <- pkgs - , let pkgid = packageId pkg] + , let pkgid = packageId pkg + pkg_key = readyPackageKey comp pkg ] let taskCount' = taskCount + length pkgs plan' = InstallPlan.processing pkgs plan @@ -1032,18 +1124,18 @@ waitForTasks taskCount plan = do info verbosity $ "Waiting for install task to finish..." - (pkgid, buildResult) <- collectJob jobCtl - printBuildResult pkgid buildResult + (pkgid, pkg_key, buildResult) <- collectJob jobCtl + printBuildResult pkgid pkg_key buildResult let taskCount' = taskCount-1 plan' = updatePlan pkgid buildResult plan tryNewTasks taskCount' plan' updatePlan :: PackageIdentifier -> BuildResult -> InstallPlan -> InstallPlan updatePlan pkgid (Right buildSuccess) = - InstallPlan.completed pkgid buildSuccess + InstallPlan.completed (Source.fakeInstalledPackageId pkgid) buildSuccess updatePlan pkgid (Left buildFailure) = - InstallPlan.failed pkgid buildFailure depsFailure + InstallPlan.failed (Source.fakeInstalledPackageId pkgid) buildFailure depsFailure where depsFailure = DependentFailed pkgid -- So this first pkgid failed for whatever reason (buildFailure). @@ -1053,8 +1145,8 @@ -- Print build log if something went wrong, and 'Installed $PKGID' -- otherwise. - printBuildResult :: PackageId -> BuildResult -> IO () - printBuildResult pkgid buildResult = case buildResult of + printBuildResult :: PackageId -> PackageKey -> BuildResult -> IO () + printBuildResult pkgid pkg_key buildResult = case buildResult of (Right _) -> notice verbosity $ "Installed " ++ display pkgid (Left _) -> do notice verbosity $ "Failed to install " ++ display pkgid @@ -1062,7 +1154,7 @@ case useLogFile of Nothing -> return () Just (mkLogFileName, _) -> do - let logName = mkLogFileName pkgid + let logName = mkLogFileName pkgid pkg_key putStr $ "Build log ( " ++ logName ++ " ):\n" printFile logName @@ -1077,14 +1169,14 @@ -- -- NB: when updating this function, don't forget to also update -- 'configurePackage' in D.C.Configure. -installReadyPackage :: Platform -> CompilerId +installReadyPackage :: Platform -> CompilerInfo -> ConfigFlags -> ReadyPackage -> (ConfigFlags -> PackageLocation (Maybe FilePath) -> PackageDescription -> PackageDescriptionOverride -> a) -> a -installReadyPackage platform comp configFlags +installReadyPackage platform cinfo configFlags (ReadyPackage (SourcePackage _ gpkg source pkgoverride) flags stanzas deps) installPkg = installPkg configFlags { @@ -1105,7 +1197,7 @@ where pkg = case finalizePackageDescription flags (const True) - platform comp [] (enableStanzas stanzas gpkg) of + platform cinfo [] (enableStanzas stanzas gpkg) of Left _ -> error "finalizePackageDescription ReadyPackage failed" Right (desc, _) -> desc @@ -1178,9 +1270,10 @@ installPkg (Just absUnpackedPath) where - -- 'cabal sdist' puts pre-generated files in the 'dist' directory. This - -- fails when we use a nonstandard build directory name (as is the case - -- with sandboxes), so we need to rename the 'dist' dir here. + -- 'cabal sdist' puts pre-generated files in the 'dist' + -- directory. This fails when a nonstandard build directory name + -- is used (as is the case with sandboxes), so we need to rename + -- the 'dist' dir here. -- -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still -- fails even with this workaround. We probably can live with that. @@ -1190,13 +1283,16 @@ distDirPathTmp = absUnpackedPath (defaultDistPref ++ "-tmp") distDirPathNew = absUnpackedPath distPref distDirExists <- doesDirectoryExist distDirPath - when (distDirExists && distDirPath /= distDirPathNew) $ do + when (distDirExists + && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do -- NB: we need to handle the case when 'distDirPathNew' is a - -- subdirectory of 'distDirPath' (e.g. 'dist/dist-sandbox-3688fbc2'). + -- subdirectory of 'distDirPath' (e.g. the former is + -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist'). debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '" ++ distDirPathTmp ++ "'." renameDirectory distDirPath distDirPathTmp - createDirectoryIfMissingVerbose verbosity False distDirPath + when (distDirPath `isPrefixOf` distDirPathNew) $ + createDirectoryIfMissingVerbose verbosity False distDirPath debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '" ++ distDirPathNew ++ "'." renameDirectory distDirPathTmp distDirPathNew @@ -1206,22 +1302,23 @@ -> JobLimit -> Lock -> Int + -> PackageKey -> SetupScriptOptions -> InstallMisc -> ConfigFlags -> InstallFlags -> HaddockFlags - -> CompilerId + -> CompilerInfo -> Platform -> PackageDescription -> PackageDescriptionOverride -> Maybe FilePath -- ^ Directory to change to before starting the installation. -> UseLogFile -- ^ File to log output to (if any) -> IO BuildResult -installUnpackedPackage verbosity buildLimit installLock numJobs +installUnpackedPackage verbosity buildLimit installLock numJobs pkg_key scriptOptions miscOptions configFlags installFlags haddockFlags - compid platform pkg pkgoverride workingDir useLogFile = do + cinfo platform pkg pkgoverride workingDir useLogFile = do -- Override the .cabal file if necessary case pkgoverride of @@ -1280,7 +1377,7 @@ maybePkgConf <- maybeGenPkgConf mLogPath -- Actual installation - withWin32SelfUpgrade verbosity configFlags compid platform pkg $ do + withWin32SelfUpgrade verbosity pkg_key configFlags cinfo platform pkg $ do case rootCmd miscOptions of (Just cmd) -> reexec cmd Nothing -> do @@ -1329,8 +1426,8 @@ defInstallDirs (configInstallDirs configFlags) } where - CompilerId flavor _ = compid - env = initialPathTemplateEnv pkgid compid platform + CompilerId flavor _ = compilerInfoId cinfo + env = initialPathTemplateEnv pkgid pkg_key cinfo platform userInstall = fromFlagOrDefault defaultUserInstall (configUserInstall configFlags') @@ -1364,7 +1461,7 @@ case useLogFile of Nothing -> return Nothing Just (mkLogFileName, _) -> do - let logFileName = mkLogFileName (packageId pkg) + let logFileName = mkLogFileName (packageId pkg) pkg_key logDir = takeDirectory logFileName unless (null logDir) $ createDirectoryIfMissing True logDir logFileExists <- doesFileExist logFileName @@ -1413,13 +1510,14 @@ -- ------------------------------------------------------------ withWin32SelfUpgrade :: Verbosity + -> PackageKey -> ConfigFlags - -> CompilerId + -> CompilerInfo -> Platform -> PackageDescription -> IO a -> IO a -withWin32SelfUpgrade _ _ _ _ _ action | buildOS /= Windows = action -withWin32SelfUpgrade verbosity configFlags compid platform pkg action = do +withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action +withWin32SelfUpgrade verbosity pkg_key configFlags cinfo platform pkg action = do defaultDirs <- InstallDirs.defaultInstallDirs compFlavor @@ -1431,7 +1529,7 @@ where pkgid = packageId pkg - (CompilerId compFlavor _) = compid + (CompilerId compFlavor _) = compilerInfoId cinfo exeInstallPaths defaultDirs = [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension @@ -1447,8 +1545,9 @@ templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault defaultDirs (configInstallDirs configFlags) absoluteDirs = InstallDirs.absoluteInstallDirs - pkgid compid InstallDirs.NoCopyDest + pkgid pkg_key + cinfo InstallDirs.NoCopyDest platform templateDirs substTemplate = InstallDirs.fromPathTemplate . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid compid platform + where env = InstallDirs.initialPathTemplateEnv pkgid pkg_key cinfo platform diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -24,6 +24,8 @@ completed, failed, remove, + showPlanIndex, + showInstallPlan, -- ** Query functions planPlatform, @@ -49,10 +51,11 @@ ( SourcePackage(packageDescription), ConfiguredPackage(..) , ReadyPackage(..), readyPackageToConfiguredPackage , InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas - , InstalledPackage (..) ) + , InstalledPackage(..), fakeInstalledPackageId ) import Distribution.Package ( PackageIdentifier(..), PackageName(..), Package(..), packageName - , PackageFixedDeps(..), Dependency(..) ) + , PackageFixedDeps(..), Dependency(..), InstalledPackageId + , PackageInstalled(..) ) import Distribution.Version ( Version, withinRange ) import Distribution.PackageDescription @@ -62,15 +65,15 @@ ( externalBuildDepends ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) -import Distribution.Client.PackageIndex - ( PackageIndex ) -import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex + ( PackageIndex, FakeMap ) +import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Text ( display ) import Distribution.System ( Platform ) import Distribution.Compiler - ( CompilerId(..) ) + ( CompilerInfo(..) ) import Distribution.Client.Utils ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils @@ -85,7 +88,11 @@ import Data.Graph (Graph) import Control.Exception ( assert ) +import Data.Maybe (catMaybes) +import qualified Data.Map as Map +type PlanIndex = PackageIndex PlanPackage + -- When cabal tries to install a number of packages, including all their -- dependencies it has a non-trivial problem to solve. -- @@ -150,40 +157,89 @@ depends (Installed pkg _) = depends pkg depends (Failed pkg _) = depends pkg +instance PackageInstalled PlanPackage where + installedPackageId (PreExisting pkg) = installedPackageId pkg + installedPackageId (Configured pkg) = installedPackageId pkg + installedPackageId (Processing pkg) = installedPackageId pkg + -- NB: defer to the actual installed package info in this case + installedPackageId (Installed _ (BuildOk _ _ (Just ipkg))) = installedPackageId ipkg + installedPackageId (Installed pkg _) = installedPackageId pkg + installedPackageId (Failed pkg _) = installedPackageId pkg + + installedDepends (PreExisting pkg) = installedDepends pkg + installedDepends (Configured pkg) = installedDepends pkg + installedDepends (Processing pkg) = installedDepends pkg + installedDepends (Installed _ (BuildOk _ _ (Just ipkg))) = installedDepends ipkg + installedDepends (Installed pkg _) = installedDepends pkg + installedDepends (Failed pkg _) = installedDepends pkg + data InstallPlan = InstallPlan { - planIndex :: PackageIndex PlanPackage, + planIndex :: PlanIndex, + planFakeMap :: FakeMap, planGraph :: Graph, planGraphRev :: Graph, planPkgOf :: Graph.Vertex -> PlanPackage, - planVertexOf :: PackageIdentifier -> Graph.Vertex, + planVertexOf :: InstalledPackageId -> Graph.Vertex, planPlatform :: Platform, - planCompiler :: CompilerId + planCompiler :: CompilerInfo } invariant :: InstallPlan -> Bool invariant plan = - valid (planPlatform plan) (planCompiler plan) (planIndex plan) + valid (planPlatform plan) (planCompiler plan) (planFakeMap plan) (planIndex plan) internalError :: String -> a internalError msg = error $ "InstallPlan: internal error: " ++ msg +showPlanIndex :: PlanIndex -> String +showPlanIndex index = + intercalate "\n" (map showPlanPackage (PackageIndex.allPackages index)) + where showPlanPackage p = + showPlanPackageTag p ++ " " + ++ display (packageId p) ++ " (" + ++ display (installedPackageId p) ++ ")" + +showInstallPlan :: InstallPlan -> String +showInstallPlan plan = + showPlanIndex (planIndex plan) ++ "\n" ++ + "fake map:\n " ++ intercalate "\n " (map showKV (Map.toList (planFakeMap plan))) + where showKV (k,v) = display k ++ " -> " ++ display v + +showPlanPackageTag :: PlanPackage -> String +showPlanPackageTag (PreExisting _) = "PreExisting" +showPlanPackageTag (Configured _) = "Configured" +showPlanPackageTag (Processing _) = "Processing" +showPlanPackageTag (Installed _ _) = "Installed" +showPlanPackageTag (Failed _ _) = "Failed" + -- | Build an installation plan from a valid set of resolved packages. -- -new :: Platform -> CompilerId -> PackageIndex PlanPackage +new :: Platform -> CompilerInfo -> PlanIndex -> Either [PlanProblem] InstallPlan -new platform compiler index = - case problems platform compiler index of +new platform cinfo index = + -- NB: Need to pre-initialize the fake-map with pre-existing + -- packages + let isPreExisting (PreExisting _) = True + isPreExisting _ = False + fakeMap = Map.fromList + . map (\p -> (fakeInstalledPackageId (packageId p), installedPackageId p)) + . filter isPreExisting + $ PackageIndex.allPackages index in + case problems platform cinfo fakeMap index of [] -> Right InstallPlan { planIndex = index, + planFakeMap = fakeMap, planGraph = graph, planGraphRev = Graph.transposeG graph, planPkgOf = vertexToPkgId, planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, planPlatform = platform, - planCompiler = compiler + planCompiler = cinfo } where (graph, vertexToPkgId, pkgIdToVertex) = PackageIndex.dependencyGraph index + -- NB: doesn't need to know planFakeMap because the + -- fakemap is empty at this point. noSuchPkgId = internalError "package is not in the graph" probs -> Left probs @@ -227,11 +283,13 @@ ] hasAllInstalledDeps :: ConfiguredPackage -> Maybe [Installed.InstalledPackageInfo] - hasAllInstalledDeps = mapM isInstalledDep . depends + hasAllInstalledDeps = mapM isInstalledDep . installedDepends - isInstalledDep :: PackageIdentifier -> Maybe Installed.InstalledPackageInfo + isInstalledDep :: InstalledPackageId -> Maybe Installed.InstalledPackageInfo isInstalledDep pkgid = - case PackageIndex.lookupPackageId (planIndex plan) pkgid of + -- NB: Need to check if the ID has been updated in planFakeMap, in which case we + -- might be dealing with an old pointer + case PackageIndex.fakeLookupInstalledPackageId (planFakeMap plan) (planIndex plan) pkgid of Just (Configured _) -> Nothing Just (Processing _) -> Nothing Just (Failed _ _) -> internalError depOnFailed @@ -261,15 +319,25 @@ -- * The package must exist in the graph and be in the processing state. -- * The package must have had no uninstalled dependent packages. -- -completed :: PackageIdentifier +completed :: InstalledPackageId -> BuildSuccess -> InstallPlan -> InstallPlan completed pkgid buildResult plan = assert (invariant plan') plan' where plan' = plan { - planIndex = PackageIndex.insert installed (planIndex plan) + -- NB: installation can change the IPID, so better + -- record it in the fake mapping... + planFakeMap = insert_fake_mapping buildResult + $ planFakeMap plan, + planIndex = PackageIndex.insert installed + . PackageIndex.deleteInstalledPackageId pkgid + $ planIndex plan } + -- ...but be sure to use the *old* IPID for the lookup for the + -- preexisting record installed = Installed (lookupProcessingPackage plan pkgid) buildResult + insert_fake_mapping (BuildOk _ _ (Just ipi)) = Map.insert pkgid (installedPackageId ipi) + insert_fake_mapping _ = id -- | Marks a package in the graph as having failed. It also marks all the -- packages that depended on it as having failed. @@ -277,13 +345,14 @@ -- * The package must exist in the graph and be in the processing -- state. -- -failed :: PackageIdentifier -- ^ The id of the package that failed to install +failed :: InstalledPackageId -- ^ The id of the package that failed to install -> BuildFailure -- ^ The build result to use for the failed package -> BuildFailure -- ^ The build result to use for its dependencies -> InstallPlan -> InstallPlan failed pkgid buildResult buildResult' plan = assert (invariant plan') plan' where + -- NB: failures don't update IPIDs plan' = plan { planIndex = PackageIndex.merge (planIndex plan) failures } @@ -297,18 +366,21 @@ -- | Lookup the reachable packages in the reverse dependency graph. -- packagesThatDependOn :: InstallPlan - -> PackageIdentifier -> [PlanPackage] -packagesThatDependOn plan = map (planPkgOf plan) + -> InstalledPackageId -> [PlanPackage] +packagesThatDependOn plan pkgid = map (planPkgOf plan) . tail . Graph.reachable (planGraphRev plan) . planVertexOf plan + $ Map.findWithDefault pkgid pkgid (planFakeMap plan) -- | Lookup a package that we expect to be in the processing state. -- lookupProcessingPackage :: InstallPlan - -> PackageIdentifier -> ReadyPackage + -> InstalledPackageId -> ReadyPackage lookupProcessingPackage plan pkgid = - case PackageIndex.lookupPackageId (planIndex plan) pkgid of + -- NB: processing packages are guaranteed to not indirect through + -- planFakeMap + case PackageIndex.lookupInstalledPackageId (planIndex plan) pkgid of Just (Processing pkg) -> pkg _ -> internalError $ "not in processing state or no such pkg " ++ display pkgid @@ -330,8 +402,8 @@ -- -- * if the result is @False@ use 'problems' to get a detailed list. -- -valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool -valid platform comp index = null (problems platform comp index) +valid :: Platform -> CompilerInfo -> FakeMap -> PlanIndex -> Bool +valid platform cinfo fakeMap index = null (problems platform cinfo fakeMap index) data PlanProblem = PackageInvalid ConfiguredPackage [PackageProblem] @@ -381,26 +453,26 @@ -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. -- -problems :: Platform -> CompilerId - -> PackageIndex PlanPackage -> [PlanProblem] -problems platform comp index = +problems :: Platform -> CompilerInfo -> FakeMap + -> PlanIndex -> [PlanProblem] +problems platform cinfo fakeMap index = [ PackageInvalid pkg packageProblems | Configured pkg <- PackageIndex.allPackages index - , let packageProblems = configuredPackageProblems platform comp pkg + , let packageProblems = configuredPackageProblems platform cinfo pkg , not (null packageProblems) ] - ++ [ PackageMissingDeps pkg missingDeps - | (pkg, missingDeps) <- PackageIndex.brokenPackages index ] + ++ [ PackageMissingDeps pkg (catMaybes (map (fmap packageId . PackageIndex.fakeLookupInstalledPackageId fakeMap index) missingDeps)) + | (pkg, missingDeps) <- PackageIndex.brokenPackages' fakeMap index ] ++ [ PackageCycle cycleGroup - | cycleGroup <- PackageIndex.dependencyCycles index ] + | cycleGroup <- PackageIndex.dependencyCycles' fakeMap index ] ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ] + | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies' fakeMap index ] ++ [ PackageStateInvalid pkg pkg' | pkg <- PackageIndex.allPackages index - , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg) + , Just pkg' <- map (PackageIndex.fakeLookupInstalledPackageId fakeMap index) (installedDepends pkg) , not (stateDependencyRelation pkg pkg') ] -- | The graph of packages (nodes) and dependencies (edges) must be acyclic. @@ -408,7 +480,7 @@ -- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out -- which packages are involved in dependency cycles. -- -acyclic :: PackageIndex PlanPackage -> Bool +acyclic :: PlanIndex -> Bool acyclic = null . PackageIndex.dependencyCycles -- | An installation plan is closed if for every package in the set, all of @@ -418,7 +490,7 @@ -- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out -- which packages depend on packages not in the index. -- -closed :: PackageIndex PlanPackage -> Bool +closed :: PlanIndex -> Bool closed = null . PackageIndex.brokenPackages -- | An installation plan is consistent if all dependencies that target a @@ -437,7 +509,7 @@ -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to -- find out which packages are. -- -consistent :: PackageIndex PlanPackage -> Bool +consistent :: PlanIndex -> Bool consistent = null . PackageIndex.dependencyInconsistencies -- | The states of packages have that depend on each other must respect @@ -473,9 +545,9 @@ -- in the configuration given by the flag assignment, all the package -- dependencies are satisfied by the specified packages. -- -configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool -configuredPackageValid platform comp pkg = - null (configuredPackageProblems platform comp pkg) +configuredPackageValid :: Platform -> CompilerInfo -> ConfiguredPackage -> Bool +configuredPackageValid platform cinfo pkg = + null (configuredPackageProblems platform cinfo pkg) data PackageProblem = DuplicateFlag FlagName | MissingFlag FlagName @@ -513,9 +585,9 @@ ++ " but the configuration specifies " ++ display pkgid ++ " which does not satisfy the dependency." -configuredPackageProblems :: Platform -> CompilerId +configuredPackageProblems :: Platform -> CompilerInfo -> ConfiguredPackage -> [PackageProblem] -configuredPackageProblems platform comp +configuredPackageProblems platform cinfo (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps) = [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] @@ -548,7 +620,7 @@ --TODO: use something lower level than finalizePackageDescription case finalizePackageDescription specifiedFlags (const True) - platform comp + platform cinfo [] (enableStanzas stanzas $ packageDescription pkg) of Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -16,18 +16,20 @@ symlinkBinary, ) where -#if mingw32_HOST_OS || mingw32_TARGET_OS +#if mingw32_HOST_OS import Distribution.Package (PackageIdentifier) import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Setup (InstallFlags) import Distribution.Simple.Setup (ConfigFlags) +import Distribution.Simple.Compiler -symlinkBinaries :: ConfigFlags +symlinkBinaries :: Compiler + -> ConfigFlags -> InstallFlags -> InstallPlan -> IO [(PackageIdentifier, String, FilePath)] -symlinkBinaries _ _ _ = return [] +symlinkBinaries _ _ _ _ = return [] symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" @@ -42,7 +44,7 @@ import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Package - ( PackageIdentifier, Package(packageId) ) + ( PackageIdentifier, Package(packageId), mkPackageKey, PackageKey ) import Distribution.Compiler ( CompilerId(..) ) import qualified Distribution.PackageDescription as PackageDescription @@ -53,6 +55,9 @@ import Distribution.Simple.Setup ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Simple.Compiler + ( Compiler, CompilerInfo(..), packageKeySupported ) import System.Posix.Files ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink @@ -91,11 +96,12 @@ -- controlled from the config file. Of course it only works on POSIX systems -- with symlinks so is not available to Windows users. -- -symlinkBinaries :: ConfigFlags +symlinkBinaries :: Compiler + -> ConfigFlags -> InstallFlags -> InstallPlan -> IO [(PackageIdentifier, String, FilePath)] -symlinkBinaries configFlags installFlags plan = +symlinkBinaries comp configFlags installFlags plan = case flagToMaybe (installSymlinkBinDir installFlags) of Nothing -> return [] Just symlinkBinDir @@ -105,7 +111,7 @@ -- TODO: do we want to do this here? : -- createDirectoryIfMissing True publicBinDir fmap catMaybes $ sequence - [ do privateBinDir <- pkgBinDir pkg + [ do privateBinDir <- pkgBinDir pkg pkg_key ok <- symlinkBinary publicBinDir privateBinDir publicExeName privateExeName @@ -113,15 +119,17 @@ then return Nothing else return (Just (pkgid, publicExeName, privateBinDir privateExeName)) - | (pkg, exe) <- exes - , let publicExeName = PackageDescription.exeName exe + | (ReadyPackage _ _flags _ deps, pkg, exe) <- exes + , let pkgid = packageId pkg + pkg_key = mkPackageKey (packageKeySupported comp) pkgid + (map Installed.packageKey deps) [] + publicExeName = PackageDescription.exeName exe privateExeName = prefix ++ publicExeName ++ suffix - pkgid = packageId pkg - prefix = substTemplate pkgid prefixTemplate - suffix = substTemplate pkgid suffixTemplate ] + prefix = substTemplate pkgid pkg_key prefixTemplate + suffix = substTemplate pkgid pkg_key suffixTemplate ] where exes = - [ (pkg, exe) + [ (cpkg, pkg, exe) | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan , let pkg = pkgDescription cpkg , exe <- PackageDescription.executables pkg @@ -131,14 +139,14 @@ pkgDescription (ReadyPackage (SourcePackage _ pkg _ _) flags stanzas _) = case finalizePackageDescription flags (const True) - platform compilerId [] (enableStanzas stanzas pkg) of + platform cinfo [] (enableStanzas stanzas pkg) of Left _ -> error "finalizePackageDescription ReadyPackage failed" Right (desc, _) -> desc -- This is sadly rather complicated. We're kind of re-doing part of the -- configuration for the package. :-( - pkgBinDir :: PackageDescription -> IO FilePath - pkgBinDir pkg = do + pkgBinDir :: PackageDescription -> PackageKey -> IO FilePath + pkgBinDir pkg pkg_key = do defaultDirs <- InstallDirs.defaultInstallDirs compilerFlavor (fromFlag (configUserInstall configFlags)) @@ -146,19 +154,22 @@ let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault defaultDirs (configInstallDirs configFlags) absoluteDirs = InstallDirs.absoluteInstallDirs - (packageId pkg) compilerId InstallDirs.NoCopyDest + (packageId pkg) pkg_key + cinfo InstallDirs.NoCopyDest platform templateDirs canonicalizePath (InstallDirs.bindir absoluteDirs) - substTemplate pkgid = InstallDirs.fromPathTemplate - . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid compilerId platform + substTemplate pkgid pkg_key = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid pkg_key + cinfo platform fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) platform = InstallPlan.planPlatform plan - compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan + cinfo = InstallPlan.planCompiler plan + (CompilerId compilerFlavor _) = compilerInfoId cinfo symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir -- eg @/home/user/bin@ diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -31,6 +31,7 @@ import Distribution.Simple.Utils ( equating, comparing, die, notice ) import Distribution.Simple.Setup (fromFlag) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Version @@ -86,16 +87,30 @@ prefs name = fromMaybe anyVersion (Map.lookup name (packagePreferences sourcePkgDb)) - pkgsInfo :: [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])] + pkgsInfo :: + [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])] pkgsInfo -- gather info for all packages - | null pats = mergePackages (InstalledPackageIndex.allPackages installedPkgIndex) - ( PackageIndex.allPackages sourcePkgIndex) + | null pats = mergePackages + (InstalledPackageIndex.allPackages installedPkgIndex) + ( PackageIndex.allPackages sourcePkgIndex) -- gather info for packages matching search term - | otherwise = mergePackages (matchingPackages InstalledPackageIndex.searchByNameSubstring installedPkgIndex) - (matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchByNameSubstring idx n)) sourcePkgIndex) + | otherwise = pkgsInfoMatching + pkgsInfoMatching :: + [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])] + pkgsInfoMatching = + let matchingInstalled = matchingPackages + InstalledPackageIndex.searchByNameSubstring + installedPkgIndex + matchingSource = matchingPackages + (\ idx n -> + concatMap snd + (PackageIndex.searchByNameSubstring idx n)) + sourcePkgIndex + in mergePackages matchingInstalled matchingSource + matches :: [PackageDisplayInfo] matches = [ mergePackageInfo pref installedPkgs sourcePkgs selectedPkg False @@ -168,8 +183,10 @@ -- just available source packages, so we must resolve targets using -- the combination of installed and source packages. let sourcePkgs' = PackageIndex.fromList - $ map packageId (InstalledPackageIndex.allPackages installedPkgIndex) - ++ map packageId ( PackageIndex.allPackages sourcePkgIndex) + $ map packageId + (InstalledPackageIndex.allPackages installedPkgIndex) + ++ map packageId + (PackageIndex.allPackages sourcePkgIndex) pkgSpecifiers <- resolveUserTargets verbosity (fromFlag $ globalWorldFile globalFlags) sourcePkgs' userTargets @@ -186,11 +203,12 @@ where gatherPkgInfo :: (PackageName -> VersionRange) -> - InstalledPackageIndex.PackageIndex -> + InstalledPackageIndex -> PackageIndex.PackageIndex SourcePackage -> PackageSpecifier SourcePackage -> Either String PackageDisplayInfo - gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (NamedPackage name constraints) + gatherPkgInfo prefs installedPkgIndex sourcePkgIndex + (NamedPackage name constraints) | null (selectedInstalledPkgs) && null (selectedSourcePkgs) = Left $ "There is no available version of " ++ display name ++ " that satisfies " @@ -204,10 +222,11 @@ (pref, installedPkgs, sourcePkgs) = sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex - selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex - (Dependency name verConstraint) - selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex - (Dependency name verConstraint) + selectedInstalledPkgs = InstalledPackageIndex.lookupDependency + installedPkgIndex + (Dependency name verConstraint) + selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex + (Dependency name verConstraint) selectedSourcePkg' = latestWithPref pref selectedSourcePkgs -- display a specific package version if the user @@ -216,7 +235,8 @@ verConstraint = foldr intersectVersionRanges anyVersion verConstraints verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ] - gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) = + gatherPkgInfo prefs installedPkgIndex sourcePkgIndex + (SpecificSourcePackage pkg) = Right $ mergePackageInfo pref installedPkgs sourcePkgs selectedPkg True where @@ -228,15 +248,16 @@ sourcePkgsInfo :: (PackageName -> VersionRange) -> PackageName - -> InstalledPackageIndex.PackageIndex + -> InstalledPackageIndex -> PackageIndex.PackageIndex SourcePackage -> (VersionRange, [Installed.InstalledPackageInfo], [SourcePackage]) sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex = (pref, installedPkgs, sourcePkgs) where pref = prefs name - installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name) - sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name + installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName + installedPkgIndex name) + sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name -- | The info that we can display for each package. It is information per @@ -429,11 +450,14 @@ hasExe = fromMaybe False (fmap (not . null . Source.condExecutables) sourceGeneric), executables = map fst (maybe [] Source.condExecutables sourceGeneric), - modules = combine Installed.exposedModules installed - (maybe [] Source.exposedModules - . Source.library) source, - dependencies = combine (map (SourceDependency . simplifyDependency) . Source.buildDepends) source - (map InstalledDependency . Installed.depends) installed, + modules = combine (map Installed.exposedName . Installed.exposedModules) + installed + (maybe [] getListOfExposedModules . Source.library) + source, + dependencies = + combine (map (SourceDependency . simplifyDependency) + . Source.buildDepends) source + (map InstalledDependency . Installed.depends) installed, haddockHtml = fromMaybe "" . join . fmap (listToMaybe . Installed.haddockHTMLs) $ installed, @@ -443,6 +467,10 @@ combine f x g y = fromJust (fmap f x `mplus` fmap g y) installed :: Maybe Installed.InstalledPackageInfo installed = latestWithPref versionPref installedPkgs + + getListOfExposedModules lib = Source.exposedModules lib + ++ map Source.moduleReexportName + (Source.reexportedModules lib) sourceSelected | isJust selectedPkg = selectedPkg diff --git a/Distribution/Client/PackageIndex.hs b/Distribution/Client/PackageIndex.hs --- a/Distribution/Client/PackageIndex.hs +++ b/Distribution/Client/PackageIndex.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.PackageIndex @@ -87,10 +88,7 @@ -- (Map PackageName [pkg]) - deriving (Show, Read) - -instance Functor PackageIndex where - fmap f (PackageIndex m) = PackageIndex (fmap (map f) m) + deriving (Show, Read, Functor) instance Package pkg => Monoid (PackageIndex pkg) where mempty = PackageIndex Map.empty diff --git a/Distribution/Client/Run.hs b/Distribution/Client/Run.hs --- a/Distribution/Client/Run.hs +++ b/Distribution/Client/Run.hs @@ -14,12 +14,20 @@ import Distribution.PackageDescription (Executable (..), PackageDescription (..)) +import Distribution.Simple.Compiler (compilerFlavor, CompilerFlavor(..)) import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import Distribution.Simple.BuildPaths (exeExtension) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..)) -import Distribution.Simple.Utils (die, rawSystemExitWithEnv) +import Distribution.Simple.LocalBuildInfo (ComponentName (..), + LocalBuildInfo (..), + getComponentLocalBuildInfo, + depLibraryPaths) +import Distribution.Simple.Utils (die, notice, rawSystemExitWithEnv, + addLibraryPath) +import Distribution.System (Platform (..)) import Distribution.Verbosity (Verbosity) +import qualified Distribution.Simple.GHCJS as GHCJS + import Data.Functor ((<$>)) import Data.List (find) import System.Directory (getCurrentDirectory) @@ -58,7 +66,27 @@ dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir", curDir dataDir pkg_descr) - path <- tryCanonicalizePath $ - buildPref exeName exe (exeName exe <.> exeExtension) + (path, runArgs) <- + case compilerFlavor (compiler lbi) of + GHCJS -> do + let (script, cmd, cmdArgs) = + GHCJS.runCmd (withPrograms lbi) + (buildPref exeName exe exeName exe) + script' <- tryCanonicalizePath script + return (cmd, cmdArgs ++ [script']) + _ -> do + p <- tryCanonicalizePath $ + buildPref exeName exe (exeName exe <.> exeExtension) + return (p, []) + env <- (dataDirEnvVar:) <$> getEnvironment - rawSystemExitWithEnv verbosity path exeArgs env + -- Add (DY)LD_LIBRARY_PATH if needed + env' <- if withDynExe lbi + then do let (Platform _ os) = hostPlatform lbi + clbi = getComponentLocalBuildInfo lbi + (CExeName (exeName exe)) + paths <- depLibraryPaths True False lbi clbi + return (addLibraryPath os paths env) + else return env + notice verbosity $ "Running " ++ exeName exe ++ "..." + rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env' diff --git a/Distribution/Client/Sandbox.hs b/Distribution/Client/Sandbox.hs --- a/Distribution/Client/Sandbox.hs +++ b/Distribution/Client/Sandbox.hs @@ -54,6 +54,8 @@ makeInstallContext, makeInstallPlan, processInstallPlan ) +import Distribution.Utils.NubList ( fromNubList ) + import Distribution.Client.Sandbox.PackageEnvironment ( PackageEnvironment(..), IncludeComments(..), PackageEnvironmentType(..) , createPackageEnvironmentFile, classifyPackageEnvironment @@ -64,7 +66,8 @@ , UseSandbox(..) ) import Distribution.Client.Types ( PackageLocation(..) , SourcePackage(..) ) -import Distribution.Client.Utils ( inDir, tryCanonicalizePath ) +import Distribution.Client.Utils ( inDir, tryCanonicalizePath + , tryFindAddSourcePackageDesc ) import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.PackageDescription.Parse ( readPackageDescription ) @@ -80,7 +83,6 @@ import Distribution.Simple.SrcDist ( prepareTree ) import Distribution.Simple.Utils ( die, debug, notice, info, warn , debugNoWrap, defaultPackageDesc - , tryFindPackageDesc , intercalate, topHandlerWith , createDirectoryIfMissingVerbose ) import Distribution.Package ( Package(..) ) @@ -90,6 +92,7 @@ import Distribution.Client.Compat.Environment ( lookupEnv, setEnv ) import Distribution.Client.Compat.FilePerms ( setFileHidden ) import qualified Distribution.Client.Sandbox.Index as Index +import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Simple.Register as Register import qualified Data.Map as M @@ -196,7 +199,7 @@ -- 'SavedConfig'. tryGetIndexFilePath' :: GlobalFlags -> IO FilePath tryGetIndexFilePath' globalFlags = do - let paths = globalLocalRepos globalFlags + let paths = fromNubList $ globalLocalRepos globalFlags case paths of [] -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ "no local repos found. " ++ checkConfiguration @@ -228,7 +231,7 @@ -- | Which packages are installed in the sandbox package DB? getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags -> Compiler -> ProgramConfiguration - -> IO InstalledPackageIndex.PackageIndex + -> IO InstalledPackageIndex getInstalledPackagesInSandbox verbosity configFlags comp conf = do sandboxDB <- getSandboxPackageDB configFlags getPackageDBContents verbosity comp sandboxDB conf @@ -323,9 +326,12 @@ -- | Entry point for the 'cabal sandbox delete' command. sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () sandboxDelete verbosity _sandboxFlags globalFlags = do - (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty + (useSandbox, _) <- loadConfigOrSandboxConfig + verbosity + globalFlags { globalRequireSandbox = Flag False } + mempty case useSandbox of - NoSandbox -> die "Not in a sandbox." + NoSandbox -> warn verbosity "Not in a sandbox." UseSandbox sandboxDir -> do curDir <- getCurrentDirectory pkgEnvFile <- getSandboxConfigFilePath globalFlags @@ -527,7 +533,9 @@ flag = (globalRequireSandbox . savedGlobalFlags $ config) `mappend` (globalRequireSandbox globalFlags) checkFlag (Flag True) = - die $ "'require-sandbox' is set to True, but no sandbox is present." + die $ "'require-sandbox' is set to True, but no sandbox is present. " + ++ "Use '--no-require-sandbox' if you want to override " + ++ "'require-sandbox' temporarily." checkFlag (Flag False) = return () checkFlag (NoFlag) = return () @@ -618,9 +626,9 @@ -- List all packages installed in the sandbox. installedPkgIndex <- getInstalledPackagesInSandbox verbosity configFlags comp conf - + let err = "Error reading sandbox package information." -- Get the package descriptions for all add-source deps. - depsCabalFiles <- mapM tryFindPackageDesc buildTreeRefs + depsCabalFiles <- mapM (flip tryFindAddSourcePackageDesc err) buildTreeRefs depsPkgDescs <- mapM (readPackageDescription verbosity) depsCabalFiles let depsMap = M.fromList (zip buildTreeRefs depsPkgDescs) isInstalled pkgid = not . null diff --git a/Distribution/Client/Sandbox/Index.hs b/Distribution/Client/Sandbox/Index.hs --- a/Distribution/Client/Sandbox/Index.hs +++ b/Distribution/Client/Sandbox/Index.hs @@ -22,6 +22,7 @@ import Distribution.Client.IndexUtils ( BuildTreeRefType(..) , refTypeFromTypeCode , typeCodeFromRefType + , updatePackageIndexCacheFile , getSourcePackagesStrict ) import Distribution.Client.PackageIndex ( allPackages ) import Distribution.Client.Types ( Repo(..), LocalRepo(..) @@ -29,9 +30,10 @@ , SourcePackage(..), PackageLocation(..) ) import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString , makeAbsoluteToCwd, tryCanonicalizePath - , canonicalizePathNoThrow ) + , canonicalizePathNoThrow + , tryFindAddSourcePackageDesc ) -import Distribution.Simple.Utils ( die, debug, tryFindPackageDesc ) +import Distribution.Simple.Utils ( die, debug ) import Distribution.Verbosity ( Verbosity ) import qualified Data.ByteString.Lazy as BS @@ -42,7 +44,8 @@ import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist, renameFile ) -import System.FilePath ( (), (<.>), takeDirectory, takeExtension ) +import System.FilePath ( (), (<.>), takeDirectory, takeExtension + , replaceExtension ) import System.IO ( IOMode(..), SeekMode(..) , hSeek, withBinaryFile ) @@ -61,7 +64,7 @@ dirExists <- doesDirectoryExist dir unless dirExists $ die $ "directory '" ++ dir ++ "' does not exist" - _ <- tryFindPackageDesc dir + _ <- tryFindAddSourcePackageDesc dir "Error adding source reference." return . Just $ BuildTreeRef refType dir -- | Given a tar archive entry, try to parse it as a local build tree reference. @@ -149,6 +152,8 @@ hSeek h AbsoluteSeek (fromIntegral offset) BS.hPut h (Tar.write entries) debug verbosity $ "Successfully appended to '" ++ path ++ "'" + updatePackageIndexCacheFile verbosity path + (path `replaceExtension` "cache") -- | Remove given local build tree references from the index. removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath] @@ -163,10 +168,10 @@ -- much smaller. BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read =<< BS.readFile path - -- This invalidates the cache, so we don't have to update it explicitly. renameFile tmpFile path debug verbosity $ "Successfully renamed '" ++ tmpFile ++ "' to '" ++ path ++ "'" + updatePackageIndexCacheFile verbosity path (path `replaceExtension` "cache") -- FIXME: return only the refs that vere actually removed. return l where diff --git a/Distribution/Client/Sandbox/PackageEnvironment.hs b/Distribution/Client/Sandbox/PackageEnvironment.hs --- a/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -39,8 +39,9 @@ import Distribution.Client.Setup ( GlobalFlags(..), ConfigExFlags(..) , InstallFlags(..) , defaultSandboxLocation ) +import Distribution.Utils.NubList ( toNubList ) import Distribution.Simple.Compiler ( Compiler, PackageDB(..) - , compilerFlavor, showCompilerId ) + , compilerFlavor, showCompilerIdWithAbi ) import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate , defaultInstallDirs, combineInstallDirs , fromPathTemplate, toPathTemplate ) @@ -200,12 +201,12 @@ savedUserInstallDirs = installDirs, savedGlobalInstallDirs = installDirs, savedGlobalFlags = (savedGlobalFlags initialConfig) { - globalLocalRepos = [sandboxDir "packages"] + globalLocalRepos = toNubList [sandboxDir "packages"] }, savedConfigureFlags = setPackageDB sandboxDir compiler platform (savedConfigureFlags initialConfig), savedInstallFlags = (savedInstallFlags initialConfig) { - installSummaryFile = [toPathTemplate (sandboxDir + installSummaryFile = toNubList [toPathTemplate (sandboxDir "logs" "build.log")] } } @@ -216,9 +217,11 @@ sandboxPackageDBPath sandboxDir compiler platform = sandboxDir (Text.display platform ++ "-" - ++ showCompilerId compiler + ++ showCompilerIdWithAbi compiler ++ "-packages.conf.d") - +-- The path in sandboxPackageDBPath should be kept in sync with the +-- path in the bootstrap.sh which is used to bootstrap cabal-install +-- into a sandbox. -- | Use the package DB location specific for this compiler. setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags @@ -325,7 +328,8 @@ pkgEnv <- handleParseResult verbosity pkgEnvFile minp -- Get the saved sandbox directory. - -- TODO: Use substPathTemplate with compilerTemplateEnv ++ platformTemplateEnv. + -- TODO: Use substPathTemplate with + -- compilerTemplateEnv ++ platformTemplateEnv ++ abiTemplateEnv. let sandboxDir = fromFlagOrDefault defaultSandboxLocation . fmap fromPathTemplate . prefix . savedUserInstallDirs . pkgEnvSavedConfig $ pkgEnv @@ -470,10 +474,7 @@ configProgramPaths = paths, configProgramArgs = args }, - savedHaddockFlags = haddockFlags { - haddockProgramPaths = paths, - haddockProgramArgs = args - }, + savedHaddockFlags = haddockFlags, savedUserInstallDirs = installDirs, savedGlobalInstallDirs = installDirs } diff --git a/Distribution/Client/Sandbox/Timestamp.hs b/Distribution/Client/Sandbox/Timestamp.hs --- a/Distribution/Client/Sandbox/Timestamp.hs +++ b/Distribution/Client/Sandbox/Timestamp.hs @@ -16,6 +16,7 @@ listModifiedDeps, ) where +import Control.Exception (IOException) import Control.Monad (filterM, forM, when) import Data.Char (isSpace) import Data.List (partition) @@ -31,8 +32,7 @@ SDistFlags (..), defaultSDistFlags, sdistCommand) -import Distribution.Simple.Utils (debug, die, - tryFindPackageDesc, warn) +import Distribution.Simple.Utils (debug, die, warn) import Distribution.System (Platform) import Distribution.Text (display) import Distribution.Verbosity (Verbosity, lessVerbose, @@ -41,13 +41,13 @@ orLaterVersion) import Distribution.Client.Sandbox.Index - (ListIgnoredBuildTreeRefs (DontListIgnored), RefTypesToList(OnlyLinks) + (ListIgnoredBuildTreeRefs (ListIgnored), RefTypesToList(OnlyLinks) ,listBuildTreeRefs) import Distribution.Client.SetupWrapper (SetupScriptOptions (..), defaultSetupScriptOptions, setupWrapper) -import Distribution.Client.Utils (inDir, removeExistingFile, - tryCanonicalizePath) +import Distribution.Client.Utils + (inDir, removeExistingFile, tryCanonicalizePath, tryFindAddSourcePackageDesc) import Distribution.Compat.Exception (catchIO) import Distribution.Client.Compat.Time (EpochTime, getCurTime, @@ -141,15 +141,16 @@ -> IO () maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile compId platform = do - buildTreeRefs <- listBuildTreeRefs verbosity DontListIgnored OnlyLinks - indexFile + let key = timestampRecordKey compId platform withTimestampFile sandboxDir $ \timestampRecords -> do - let key = timestampRecordKey compId platform case lookup key timestampRecords of Just _ -> return timestampRecords - Nothing -> do now <- getCurTime - let timestamps = map (\p -> (p, now)) buildTreeRefs - return $ (key, timestamps):timestampRecords + Nothing -> do + buildTreeRefs <- listBuildTreeRefs verbosity ListIgnored OnlyLinks + indexFile + now <- getCurTime + let timestamps = map (\p -> (p, now)) buildTreeRefs + return $ (key, timestamps):timestampRecords -- | Given an IO action that returns a list of build tree refs, add those -- build tree refs to the timestamps file (for all compilers). @@ -213,9 +214,10 @@ -- FIXME: This function is not thread-safe because of 'inDir'. allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do - pkg <- fmap (flattenPackageDescription) - . readPackageDescription verbosity =<< tryFindPackageDesc packageDir - + pkg <- do + let err = "Error reading source files of add-source dependency." + desc <- tryFindAddSourcePackageDesc packageDir err + flattenPackageDescription `fmap` readPackageDescription verbosity desc let file = "cabal-sdist-list-sources" flags = defaultSDistFlags { sDistVerbosity = Flag $ if verbosity == normal @@ -233,13 +235,16 @@ srcs <- fmap lines . readFile $ file mapM tryCanonicalizePath srcs - onFailedListSources :: IO () - onFailedListSources = warn verbosity $ + onFailedListSources :: IOException -> IO () + onFailedListSources e = do + warn verbosity $ "Could not list sources of the add-source dependency '" ++ display (packageName pkg) ++ "'. Skipping the timestamp check." + debug verbosity $ + "Exception was: " ++ show e -- Run setup sdist --list-sources=TMPFILE - ret <- doListSources `catchIO` (\_ -> onFailedListSources >> return []) + ret <- doListSources `catchIO` (\e -> onFailedListSources e >> return []) removeExistingFile file return ret diff --git a/Distribution/Client/Sandbox/Types.hs b/Distribution/Client/Sandbox/Types.hs --- a/Distribution/Client/Sandbox/Types.hs +++ b/Distribution/Client/Sandbox/Types.hs @@ -51,7 +51,7 @@ -- ^ Remaining add-source deps. Some of these may be not installed in the -- sandbox. - otherInstalledSandboxPackages :: !InstalledPackageIndex.PackageIndex, + otherInstalledSandboxPackages :: !InstalledPackageIndex.InstalledPackageIndex, -- ^ All packages installed in the sandbox. Intersection with -- 'modifiedAddSourceDependencies' and/or 'otherAddSourceDependencies' can be -- non-empty. diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -16,7 +16,7 @@ , configureExCommand, ConfigExFlags(..), defaultConfigExFlags , configureExOptions , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) - , testCommand, benchmarkCommand + , replCommand, testCommand, benchmarkCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , listCommand, ListFlags(..) , updateCommand @@ -35,6 +35,7 @@ , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..) , sandboxCommand, defaultSandboxLocation, SandboxFlags(..) , execCommand, ExecFlags(..) + , userConfigCommand, UserConfigFlags(..) , parsePackageArgs --TODO: stop exporting these: @@ -52,6 +53,8 @@ ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets ( UserConstraint, readUserConstraint ) +import Distribution.Utils.NubList + ( NubList, toNubList, fromNubList) import Distribution.Simple.Compiler (PackageDB) import Distribution.Simple.Program @@ -60,7 +63,8 @@ import qualified Distribution.Simple.Command as Command import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup - ( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..) + ( ConfigFlags(..), BuildFlags(..), ReplFlags + , TestFlags(..), BenchmarkFlags(..) , SDistFlags(..), HaddockFlags(..) , readPackageDbList, showPackageDbList , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList @@ -83,12 +87,12 @@ import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils - ( wrapText ) + ( wrapText, wrapLine ) import Data.Char ( isSpace, isAlphaNum ) import Data.List - ( intercalate ) + ( intercalate, deleteFirstsBy ) import Data.Maybe ( listToMaybe, maybeToList, fromMaybe ) import Data.Monoid @@ -110,9 +114,9 @@ globalNumericVersion :: Flag Bool, globalConfigFile :: Flag FilePath, globalSandboxConfigFile :: Flag FilePath, - globalRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. + globalRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. globalCacheDir :: Flag FilePath, - globalLocalRepos :: [FilePath], + globalLocalRepos :: NubList FilePath, globalLogsDir :: Flag FilePath, globalWorldFile :: Flag FilePath, globalRequireSandbox :: Flag Bool, @@ -134,21 +138,120 @@ globalIgnoreSandbox = Flag False } -globalCommand :: CommandUI GlobalFlags -globalCommand = CommandUI { +globalCommand :: [Command action] -> CommandUI GlobalFlags +globalCommand commands = CommandUI { commandName = "", - commandSynopsis = "", - commandUsage = \_ -> - "This program is the command line interface " - ++ "to the Haskell Cabal infrastructure.\n" - ++ "See http://www.haskell.org/cabal/ for more information.\n", + commandSynopsis = + "Command line interface to the Haskell Cabal infrastructure.", + commandUsage = \pname -> + "See http://www.haskell.org/cabal/ for more information.\n" + ++ "\n" + ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n", commandDescription = Just $ \pname -> - "For more information about a command use:\n" - ++ " " ++ pname ++ " COMMAND --help\n\n" + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + -- if new commands are added, we want them to appear even if they + -- are not included in the custom listing below. Thus, we calculate + -- the `otherCmds` list and append it under the `other` category. + -- Alternatively, a new testcase could be added that ensures that + -- the set of commands listed here is equal to the set of commands + -- that are actually available. + otherCmds = deleteFirstsBy (==) (map fst cmdDescs) + [ "help" + , "update" + , "install" + , "fetch" + , "list" + , "info" + , "user-config" + , "get" + , "init" + , "configure" + , "build" + , "clean" + , "run" + , "repl" + , "test" + , "bench" + , "check" + , "sdist" + , "upload" + , "report" + , "freeze" + , "haddock" + , "hscolour" + , "copy" + , "register" + , "sandbox" + , "exec" + ] + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + startGroup n = " ["++n++"]" + par = "" + addCmd n = case lookup n cmdDescs of + Nothing -> "" + Just d -> " " ++ align n ++ " " ++ d + addCmdCustom n d = case lookup n cmdDescs of -- make sure that the + -- command still exists. + Nothing -> "" + Just _ -> " " ++ align n ++ " " ++ d + in + "Commands:\n" + ++ unlines ( + [ startGroup "global" + , addCmd "update" + , addCmd "install" + , par + , addCmd "help" + , addCmd "info" + , addCmd "list" + , addCmd "fetch" + , addCmd "user-config" + , par + , startGroup "package" + , addCmd "get" + , addCmd "init" + , par + , addCmd "configure" + , addCmd "build" + , addCmd "clean" + , par + , addCmd "run" + , addCmd "repl" + , addCmd "test" + , addCmd "bench" + , par + , addCmd "check" + , addCmd "sdist" + , addCmd "upload" + , addCmd "report" + , par + , addCmd "freeze" + , addCmd "haddock" + , addCmd "hscolour" + , addCmd "copy" + , addCmd "register" + , par + , startGroup "sandbox" + , addCmd "sandbox" + , addCmd "exec" + , addCmdCustom "repl" "Open interpreter with access to sandbox packages." + ] ++ if null otherCmds then [] else par + :startGroup "other" + :[addCmd n | n <- otherCmds]) + ++ "\n" + ++ "For more information about a command use:\n" + ++ " " ++ pname ++ " COMMAND --help\n" + ++ "or " ++ pname ++ " help COMMAND\n" + ++ "\n" ++ "To install Cabal packages from hackage use:\n" - ++ " " ++ pname ++ " install foo [--dry-run]\n\n" + ++ " " ++ pname ++ " install foo [--dry-run]\n" + ++ "\n" ++ "Occasionally you need to update the list of available packages:\n" ++ " " ++ pname ++ " update\n", + commandNotes = Nothing, commandDefaultFlags = mempty, commandOptions = \showOrParseArgs -> (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id) @@ -186,7 +289,7 @@ ,option [] ["remote-repo"] "The name and url for a remote repository" globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) - (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo)) + (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList)) ,option [] ["remote-repo-cache"] "The location where downloads from all remote repos are cached" @@ -196,7 +299,7 @@ ,option [] ["local-repo"] "The location of a local repository" globalLocalRepos (\v flags -> flags { globalLocalRepos = v }) - (reqArg' "DIR" (\x -> [x]) id) + (reqArg' "DIR" (\x -> toNubList [x]) fromNubList) ,option [] ["logs-dir"] "The location to put log files" @@ -244,12 +347,12 @@ where remoteRepos = [ Repo (Left remote) cacheDir - | remote <- globalRemoteRepos globalFlags + | remote <- fromNubList $ globalRemoteRepos globalFlags , let cacheDir = fromFlag (globalCacheDir globalFlags) remoteRepoName remote ] localRepos = [ Repo (Right LocalRepo) local - | local <- globalLocalRepos globalFlags ] + | local <- fromNubList $ globalLocalRepos globalFlags ] -- ------------------------------------------------------------ -- * Config flags @@ -272,18 +375,21 @@ | cabalLibVersion < Version [1,18,0] [] = flags_1_18_0 | cabalLibVersion < Version [1,19,1] [] = flags_1_19_0 | cabalLibVersion < Version [1,19,2] [] = flags_1_19_1 + | cabalLibVersion < Version [1,21,1] [] = flags_1_20_0 | otherwise = flags_latest where -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'. flags_latest = flags { configConstraints = [] } + -- Cabal < 1.21.1 doesn't know about 'disable-relocatable' + flags_1_20_0 = flags_latest { configRelocatable = NoFlag } -- Cabal < 1.19.2 doesn't know about '--exact-configuration'. - flags_1_19_1 = flags_latest { configExactConfiguration = NoFlag } + flags_1_19_1 = flags_1_20_0 { configExactConfiguration = NoFlag } -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'. flags_1_19_0 = flags_1_19_1 { configDependencies = [] , configConstraints = configConstraints flags } -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir. - flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = [] + flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = toNubList [] , configInstallDirs = configInstallDirs_1_18_0} configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag } -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'. @@ -351,13 +457,14 @@ , optionSolver configSolver (\v flags -> flags { configSolver = v }) , option [] ["allow-newer"] - "Ignore upper bounds in dependencies on some or all packages." + ("Ignore upper bounds in all dependencies or " ++ allowNewerArgument) configAllowNewer (\v flags -> flags { configAllowNewer = v}) - (optArg "PKGS" + (optArg allowNewerArgument (fmap Flag allowNewerParser) (Flag AllowNewerAll) allowNewerPrinter) ] + where allowNewerArgument = "DEPS" instance Monoid ConfigExFlags where mempty = ConfigExFlags { @@ -422,6 +529,25 @@ where combine field = field a `mappend` field b -- ------------------------------------------------------------ +-- * Repl command +-- ------------------------------------------------------------ + +replCommand :: CommandUI (ReplFlags, BuildExFlags) +replCommand = parent { + commandDefaultFlags = (commandDefaultFlags parent, mempty), + commandOptions = + \showOrParseArgs -> liftOptions fst setFst + (commandOptions parent showOrParseArgs) + ++ + liftOptions snd setSnd (buildExOptions showOrParseArgs) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + + parent = Cabal.replCommand defaultProgramConfiguration + +-- ------------------------------------------------------------ -- * Test command -- ------------------------------------------------------------ @@ -506,8 +632,12 @@ fetchCommand = CommandUI { commandName = "fetch", commandSynopsis = "Downloads packages for later installation.", - commandDescription = Nothing, - commandUsage = usagePackages "fetch", + commandUsage = usageAlternatives "fetch" [ "[FLAGS] PACKAGES" + ], + commandDescription = Just $ \_ -> + "Note that it currently is not possible to fetch the dependencies for a\n" + ++ "package in the current directory.\n", + commandNotes = Nothing, commandDefaultFlags = defaultFetchFlags, commandOptions = \ showOrParseArgs -> [ optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) @@ -550,6 +680,8 @@ data FreezeFlags = FreezeFlags { freezeDryRun :: Flag Bool, + freezeTests :: Flag Bool, + freezeBenchmarks :: Flag Bool, freezeSolver :: Flag PreSolver, freezeMaxBackjumps :: Flag Int, freezeReorderGoals :: Flag Bool, @@ -562,6 +694,8 @@ defaultFreezeFlags :: FreezeFlags defaultFreezeFlags = FreezeFlags { freezeDryRun = toFlag False, + freezeTests = toFlag False, + freezeBenchmarks = toFlag False, freezeSolver = Flag defaultSolver, freezeMaxBackjumps = Flag defaultMaxBackjumps, freezeReorderGoals = Flag False, @@ -575,8 +709,18 @@ freezeCommand = CommandUI { commandName = "freeze", commandSynopsis = "Freeze dependencies.", - commandDescription = Nothing, - commandUsage = usagePackages "freeze", + commandDescription = Just $ \_ -> wrapText $ + "Calculates a valid set of dependencies and their exact versions. " + ++ "If successful, saves the result to the file `cabal.config`.\n" + ++ "\n" + ++ "The package versions specified in `cabal.config` will be used for " + ++ "any future installs.\n" + ++ "\n" + ++ "An existing `cabal.config` is ignored and overwritten.\n", + commandNotes = Nothing, + commandUsage = usageAlternatives "freeze" ["" + ,"PACKAGES" + ], commandDefaultFlags = defaultFreezeFlags, commandOptions = \ showOrParseArgs -> [ optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v }) @@ -586,6 +730,16 @@ freezeDryRun (\v flags -> flags { freezeDryRun = v }) trueArg + , option [] ["tests"] + "freezing of the dependencies of any tests suites in the package description file." + freezeTests (\v flags -> flags { freezeTests = v }) + (boolOpt [] []) + + , option [] ["benchmarks"] + "freezing of the dependencies of any benchmarks suites in the package description file." + freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v }) + (boolOpt [] []) + ] ++ optionSolver freezeSolver (\v flags -> flags { freezeSolver = v }) : @@ -606,7 +760,12 @@ updateCommand = CommandUI { commandName = "update", commandSynopsis = "Updates list of known packages.", - commandDescription = Nothing, + commandDescription = Just $ \_ -> + "For all known remote repositories, download the package list.\n", + commandNotes = Just $ \_ -> + relevantConfigValuesText ["remote-repo" + ,"remote-repo-cache" + ,"local-repo"], commandUsage = usageFlags "update", commandDefaultFlags = toFlag normal, commandOptions = \_ -> [optionVerbosity id const] @@ -637,7 +796,13 @@ checkCommand = CommandUI { commandName = "check", commandSynopsis = "Check the package for common mistakes.", - commandDescription = Nothing, + commandDescription = Just $ \_ -> wrapText $ + "Expects a .cabal package file in the current directory.\n" + ++ "\n" + ++ "The checks correspond to the requirements to packages on Hackage. " + ++ "If no errors and warnings are reported, Hackage will accept this " + ++ "package.\n", + commandNotes = Nothing, commandUsage = \pname -> "Usage: " ++ pname ++ " check\n", commandDefaultFlags = toFlag normal, commandOptions = \_ -> [] @@ -648,7 +813,8 @@ commandName = "format", commandSynopsis = "Reformat the .cabal file using the standard style.", commandDescription = Nothing, - commandUsage = \pname -> "Usage: " ++ pname ++ " format [FILE]\n", + commandNotes = Nothing, + commandUsage = usageAlternatives "format" ["[FILE]"], commandDefaultFlags = toFlag normal, commandOptions = \_ -> [] } @@ -656,12 +822,14 @@ runCommand :: CommandUI (BuildFlags, BuildExFlags) runCommand = CommandUI { commandName = "run", - commandSynopsis = "Runs the compiled executable.", - commandDescription = Nothing, - commandUsage = - \pname -> "Usage: " ++ pname - ++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n" - ++ "Flags for run:", + commandSynopsis = "Builds and runs an executable.", + commandDescription = Just $ \_ -> wrapText $ + "Builds and then runs the specified executable. If no executable is " + ++ "specified, but the package contains just one executable, that one " + ++ "is built and executed.\n", + commandNotes = Nothing, + commandUsage = usageAlternatives "run" + ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"], commandDefaultFlags = mempty, commandOptions = \showOrParseArgs -> liftOptions fst setFst @@ -697,10 +865,10 @@ reportCommand = CommandUI { commandName = "report", commandSynopsis = "Upload build reports to a remote server.", - commandDescription = Just $ \_ -> + commandDescription = Nothing, + commandNotes = Just $ \_ -> "You can store your Hackage login in the ~/.cabal/config file\n", - commandUsage = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n" - ++ "Flags for upload:", + commandUsage = usageAlternatives "report" ["[FLAGS]"], commandDefaultFlags = defaultReportFlags, commandOptions = \_ -> [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v }) @@ -754,12 +922,13 @@ getCommand :: CommandUI GetFlags getCommand = CommandUI { commandName = "get", - commandSynopsis = "Gets a package's source code.", - commandDescription = Just $ \_ -> + commandSynopsis = "Download/Extract a package's source code (repository).", + commandDescription = Just $ \_ -> wrapText $ "Creates a local copy of a package's source code. By default it gets " ++ "the source\ntarball and unpacks it in a local subdirectory. " ++ "Alternatively, with -s it will\nget the code from the source " ++ "repository specified by the package.\n", + commandNotes = Nothing, commandUsage = usagePackages "get", commandDefaultFlags = defaultGetFlags, commandOptions = \_ -> [ @@ -831,8 +1000,17 @@ listCommand = CommandUI { commandName = "list", commandSynopsis = "List packages matching a search string.", - commandDescription = Nothing, - commandUsage = usageFlagsOrPackages "list", + commandDescription = Just $ \_ -> wrapText $ + "List all packages, or all packages matching one of the search" + ++ " strings.\n" + ++ "\n" + ++ "If there is a sandbox in the current directory and " + ++ "config:ignore-sandbox is False, use the sandbox package database. " + ++ "Otherwise, use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n", + commandNotes = Nothing, + commandUsage = usageAlternatives "list" [ "[FLAGS]" + , "[FLAGS] STRINGS"], commandDefaultFlags = defaultListFlags, commandOptions = \_ -> [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) @@ -889,8 +1067,13 @@ infoCommand = CommandUI { commandName = "info", commandSynopsis = "Display detailed information about a particular package.", - commandDescription = Nothing, - commandUsage = usagePackages "info", + commandDescription = Just $ \_ -> wrapText $ + "If there is a sandbox in the current directory and " + ++ "config:ignore-sandbox is False, use the sandbox package database. " + ++ "Otherwise, use the package database specified with --package-db. " + ++ "If not specified, use the user package database.\n", + commandNotes = Nothing, + commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"], commandDefaultFlags = defaultInfoFlags, commandOptions = \_ -> [ optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) @@ -936,9 +1119,10 @@ installOnly :: Flag Bool, installOnlyDeps :: Flag Bool, installRootCmd :: Flag String, - installSummaryFile :: [PathTemplate], + installSummaryFile :: NubList PathTemplate, installLogFile :: Flag PathTemplate, installBuildReports :: Flag ReportLevel, + installReportPlanningFailure :: Flag Bool, installSymlinkBinDir :: Flag FilePath, installOneShot :: Flag Bool, installNumJobs :: Flag (Maybe Int), @@ -965,13 +1149,15 @@ installSummaryFile = mempty, installLogFile = mempty, installBuildReports = Flag NoReports, + installReportPlanningFailure = Flag False, installSymlinkBinDir = mempty, installOneShot = Flag False, installNumJobs = mempty, installRunTests = mempty } where - docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") + docIndexFile = toPathTemplate ("$datadir" "doc" + "$arch-$os-$compiler" "index.html") allowNewerParser :: ReadE AllowNewer allowNewerParser = ReadE $ \s -> @@ -1006,13 +1192,30 @@ installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) installCommand = CommandUI { commandName = "install", - commandSynopsis = "Installs a list of packages.", - commandUsage = usageFlagsOrPackages "install", - commandDescription = Just $ \pname -> - let original = case commandDescription configureCommand of - Just desc -> desc pname ++ "\n" - Nothing -> "" - in original + commandSynopsis = "Install packages.", + commandUsage = usageAlternatives "install" [ "[FLAGS]" + , "[FLAGS] PACKAGES" + ], + commandDescription = Just $ \_ -> wrapText $ + "Installs one or more packages. By default, the installed package" + ++ " will be registered in the user's package database or, if a sandbox" + ++ " is present in the current directory, inside the sandbox.\n" + ++ "\n" + ++ "If PACKAGES are specified, downloads and installs those packages." + ++ " Otherwise, install the package in the current directory (and/or its" + ++ " dependencies) (there must be exactly one .cabal file in the current" + ++ " directory).\n" + ++ "\n" + ++ "When using a sandbox, the flags for `install` only affect the" + ++ " current command and have no effect on future commands. (To achieve" + ++ " that, `configure` must be used.)\n" + ++ " In contrast, without a sandbox, the flags to `install` are saved and" + ++ " affect future commands such as `build` and `repl`. See the help for" + ++ " `configure` for a list of commands being affected.\n", + commandNotes = Just $ \pname -> + ( case commandNotes configureCommand of + Just desc -> desc pname ++ "\n" + Nothing -> "" ) ++ "Examples:\n" ++ " " ++ pname ++ " install " ++ " Package in the current directory\n" @@ -1127,7 +1330,7 @@ , option [] ["build-summary"] "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" installSummaryFile (\v flags -> flags { installSummaryFile = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) + (reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList)) , option [] ["build-log"] "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" @@ -1143,6 +1346,11 @@ (toFlag `fmap` parse)) (flagToList . fmap display)) + , option [] ["report-planning-failure"] + "Generate build reports when the dependency solver fails. This is used by the Hackage build bot." + installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v }) + trueArg + , option [] ["one-shot"] "Do not record the packages in the world file." installOneShot (\v flags -> flags { installOneShot = v }) @@ -1186,6 +1394,7 @@ installSummaryFile = mempty, installLogFile = mempty, installBuildReports = mempty, + installReportPlanningFailure = mempty, installSymlinkBinDir = mempty, installOneShot = mempty, installNumJobs = mempty, @@ -1210,6 +1419,7 @@ installSummaryFile = combine installSummaryFile, installLogFile = combine installLogFile, installBuildReports = combine installBuildReports, + installReportPlanningFailure = combine installReportPlanningFailure, installSymlinkBinDir = combine installSymlinkBinDir, installOneShot = combine installOneShot, installNumJobs = combine installNumJobs, @@ -1240,11 +1450,12 @@ uploadCommand = CommandUI { commandName = "upload", commandSynopsis = "Uploads source packages to Hackage.", - commandDescription = Just $ \_ -> - "You can store your Hackage login in the ~/.cabal/config file\n", + commandDescription = Nothing, + commandNotes = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n" + ++ relevantConfigValuesText ["username", "password"], commandUsage = \pname -> - "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n" - ++ "Flags for upload:", + "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n", commandDefaultFlags = defaultUploadFlags, commandOptions = \_ -> [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v }) @@ -1296,19 +1507,20 @@ initCommand :: CommandUI IT.InitFlags initCommand = CommandUI { commandName = "init", - commandSynopsis = "Interactively create a .cabal file.", + commandSynopsis = "Create a new .cabal package file (interactively).", commandDescription = Just $ \_ -> wrapText $ "Cabalise a project by creating a .cabal, Setup.hs, and " - ++ "optionally a LICENSE file.\n\n" + ++ "optionally a LICENSE file.\n" + ++ "\n" ++ "Calling init with no arguments (recommended) uses an " ++ "interactive mode, which will try to guess as much as " ++ "possible and prompt you for the rest. Command-line " ++ "arguments are provided for scripting purposes. " ++ "If you don't want interactive mode, be sure to pass " ++ "the -n flag.\n", + commandNotes = Nothing, commandUsage = \pname -> - "Usage: " ++ pname ++ " init [FLAGS]\n\n" - ++ "Flags for init:", + "Usage: " ++ pname ++ " init [FLAGS]\n", commandDefaultFlags = defaultInitFlags, commandOptions = \_ -> [ option ['n'] ["non-interactive"] @@ -1537,9 +1749,9 @@ commandName = "win32selfupgrade", commandSynopsis = "Self-upgrade the executable on Windows", commandDescription = Nothing, + commandNotes = Nothing, commandUsage = \pname -> - "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n\n" - ++ "Flags for win32selfupgrade:", + "Usage: " ++ pname ++ " win32selfupgrade PID PATH\n", commandDefaultFlags = defaultWin32SelfUpgradeFlags, commandOptions = \_ -> [optionVerbosity win32SelfUpgradeVerbosity @@ -1581,14 +1793,64 @@ sandboxCommand = CommandUI { commandName = "sandbox", commandSynopsis = "Create/modify/delete a sandbox.", - commandDescription = Nothing, - commandUsage = \pname -> - "Usage: " ++ pname ++ " sandbox init\n" - ++ " or: " ++ pname ++ " sandbox delete\n" - ++ " or: " ++ pname ++ " sandbox add-source [PATHS]\n\n" - ++ " or: " ++ pname ++ " sandbox hc-pkg -- [ARGS]\n" - ++ " or: " ++ pname ++ " sandbox list-sources\n\n" - ++ "Flags for sandbox:", + commandDescription = Just $ \pname -> concat + [ paragraph $ "Sandboxes are isolated package databases that can be used" + ++ " to prevent dependency conflicts that arise when many different" + ++ " packages are installed in the same database (i.e. the user's" + ++ " database in the home directory)." + , paragraph $ "A sandbox in the current directory (created by" + ++ " `sandbox init`) will be used instead of the user's database for" + ++ " commands such as `install` and `build`. Note that (a directly" + ++ " invoked) GHC will not automatically be aware of sandboxes;" + ++ " only if called via appropriate " ++ pname + ++ " commands, e.g. `repl`, `build`, `exec`." + , paragraph $ "Currently, " ++ pname ++ " will not search for a sandbox" + ++ " in folders above the current one, so cabal will not see the sandbox" + ++ " if you are in a subfolder of a sandboxes." + , paragraph "Subcommands:" + , headLine "init:" + , indentParagraph $ "Initialize a sandbox in the current directory." + ++ " An existing package database will not be modified, but settings" + ++ " (such as the location of the database) can be modified this way." + , headLine "delete:" + , indentParagraph $ "Remove the sandbox; deleting all the packages" + ++ " installed inside." + , headLine "add-source:" + , indentParagraph $ "Make one or more local package available in the" + ++ " sandbox. PATHS may be relative or absolute." + ++ " Typical usecase is when you need" + ++ " to make a (temporary) modification to a dependency: You download" + ++ " the package into a different directory, make the modification," + ++ " and add that directory to the sandbox with `add-source`." + , indentParagraph $ "Unless given `--snapshot`, any add-source'd" + ++ " dependency that was modified since the last build will be" + ++ " re-installed automatically." + , headLine "delete-source:" + , indentParagraph $ "Remove an add-source dependency; however, this will" + ++ " not delete the package(s) that have been installed in the sandbox" + ++ " from this dependency. You can either unregister the package(s) via" + ++ " `" ++ pname ++ " sandbox hc-pkg unregister` or re-create the" + ++ " sandbox (`sandbox delete; sandbox init`)." + , headLine "list-sources:" + , indentParagraph $ "List the directories of local packages made" + ++ " available via `" ++ pname ++ " add-source`." + , headLine "hc-pkg:" + , indentParagraph $ "Similar to `ghc-pkg`, but for the sandbox package" + ++ " database. Can be used to list specific/all packages that are" + ++ " installed in the sandbox. For subcommands, see the help for" + ++ " ghc-pkg. Affected by the compiler version specified by `configure`." + ], + commandNotes = Just $ \_ -> + relevantConfigValuesText ["require-sandbox" + ,"ignore-sandbox"], + commandUsage = usageAlternatives "sandbox" + [ "init [FLAGS]" + , "delete [FLAGS]" + , "add-source [FLAGS] PATHS" + , "delete-source [FLAGS] PATHS" + , "list-sources [FLAGS]" + , "hc-pkg [FLAGS] [--] COMMAND [--] [ARGS]" + ], commandDefaultFlags = defaultSandboxFlags, commandOptions = \_ -> @@ -1636,11 +1898,39 @@ execCommand :: CommandUI ExecFlags execCommand = CommandUI { commandName = "exec", - commandSynopsis = "Run a command with the cabal environment", - commandDescription = Nothing, + commandSynopsis = "Give a command access to the sandbox package repository.", + commandDescription = Just $ \pname -> wrapText $ + -- TODO: this is too GHC-focused for my liking.. + "A directly invoked GHC will not automatically be aware of any" + ++ " sandboxes: the GHC_PACKAGE_PATH environment variable controls what" + ++ " GHC uses. `" ++ pname ++ " exec` can be used to modify this variable:" + ++ " COMMAND will be executed in a modified environment and thereby uses" + ++ " the sandbox package database.\n" + ++ "\n" + ++ "If there is no sandbox, behaves as identity (executing COMMAND).\n" + ++ "\n" + ++ "Note that other " ++ pname ++ " commands change the environment" + ++ " variable appropriately already, so there is no need to wrap those" + ++ " in `" ++ pname ++ " exec`. But with `" ++ pname ++ " exec`, the user" + ++ " has more control and can, for example, execute custom scripts which" + ++ " indirectly execute GHC.\n" + ++ "\n" + ++ "See `" ++ pname ++ " sandbox`.", + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " Install the executable package pandoc into a sandbox and run it:\n" + ++ " " ++ pname ++ " sandbox init\n" + ++ " " ++ pname ++ " install pandoc\n" + ++ " " ++ pname ++ " exec pandoc foo.md\n\n" + ++ " Install the executable package hlint into the user package database\n" + ++ " and run it:\n" + ++ " " ++ pname ++ " install --user hlint\n" + ++ " " ++ pname ++ " exec hlint Foo.hs\n\n" + ++ " Execute runghc on Foo.hs with runghc configured to use the\n" + ++ " sandbox package database (if a sandbox is being used):\n" + ++ " " ++ pname ++ " exec runghc Foo.hs\n", commandUsage = \pname -> - "Usage: " ++ pname ++ " exec [FLAGS] COMMAND [-- [ARGS...]]\n\n" - ++ "Flags for exec:", + "Usage: " ++ pname ++ " exec [FLAGS] [--] COMMAND [--] [ARGS]\n", commandDefaultFlags = defaultExecFlags, commandOptions = \_ -> @@ -1659,6 +1949,48 @@ where combine field = field a `mappend` field b -- ------------------------------------------------------------ +-- * UserConfig flags +-- ------------------------------------------------------------ + +data UserConfigFlags = UserConfigFlags { + userConfigVerbosity :: Flag Verbosity +} + +instance Monoid UserConfigFlags where + mempty = UserConfigFlags { + userConfigVerbosity = toFlag normal + } + mappend a b = UserConfigFlags { + userConfigVerbosity = combine userConfigVerbosity + } + where combine field = field a `mappend` field b + +userConfigCommand :: CommandUI UserConfigFlags +userConfigCommand = CommandUI { + commandName = "user-config", + commandSynopsis = "Display and update the user's global cabal configuration.", + commandDescription = Just $ \_ -> wrapText $ + "When upgrading cabal, the set of configuration keys and their default" + ++ " values may change. This command provides means to merge the existing" + ++ " config in ~/.cabal/config" + ++ " (i.e. all bindings that are actually defined and not commented out)" + ++ " and the default config of the new version.\n" + ++ "\n" + ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and" + ++ " the default configuration that would be created by cabal if the" + ++ " config file did not exist.\n" + ++ "update: Applies the pseudo-diff to the configuration that would be" + ++ " created by default, and write the result back to ~/.cabal/config.", + + commandNotes = Nothing, + commandUsage = usageAlternatives "user-config" ["diff", "update"], + commandDefaultFlags = mempty, + commandOptions = \ _ -> [ + optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v }) + ] + } + +-- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------ @@ -1720,22 +2052,18 @@ (yesNoOpt showOrParseArgs) ] - usageFlagsOrPackages :: String -> String -> String usageFlagsOrPackages name pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" - ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" - ++ "Flags for " ++ name ++ ":" + ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" usagePackages :: String -> String -> String usagePackages name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" - ++ "Flags for " ++ name ++ ":" + "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n" usageFlags :: String -> String -> String usageFlags name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" - ++ "Flags for " ++ name ++ ":" + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" --TODO: do we want to allow per-package flags? parsePackageArgs :: [String] -> Either String [Dependency] @@ -1778,3 +2106,31 @@ remoteRepoName = name, remoteRepoURI = uri } + +-- ------------------------------------------------------------ +-- * Helpers for Documentation +-- ------------------------------------------------------------ + +headLine :: String -> String +headLine = unlines + . map unwords + . wrapLine 79 + . words + +paragraph :: String -> String +paragraph = (++"\n") + . unlines + . map unwords + . wrapLine 79 + . words + +indentParagraph :: String -> String +indentParagraph = unlines + . map ((" "++).unwords) + . wrapLine 77 + . words + +relevantConfigValuesText :: [String] -> String +relevantConfigValuesText vs = + "Relevant global configuration keys:\n" + ++ concat [" " ++ v ++ "\n" |v <- vs] diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.SetupWrapper @@ -34,24 +35,26 @@ import Distribution.PackageDescription ( GenericPackageDescription(packageDescription) , PackageDescription(..), specVersion - , BuildType(..), knownBuildTypes ) + , BuildType(..), knownBuildTypes, defaultRenaming ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.Simple.Configure ( configCompilerEx ) -import Distribution.Compiler ( buildCompilerId ) +import Distribution.Compiler + ( buildCompilerId, CompilerFlavor(GHC, GHCJS) ) import Distribution.Simple.Compiler - ( CompilerFlavor(GHC), Compiler(compilerId) - , PackageDB(..), PackageDBStack ) + ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack ) import Distribution.Simple.PreProcess ( runSimplePreProcessor, ppUnlit ) import Distribution.Simple.Program ( ProgramConfiguration, emptyProgramConfiguration - , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram ) + , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram + , ghcjsProgram ) import Distribution.Simple.Program.Find ( programSearchPathAsPATHVar ) import Distribution.Simple.Program.Run ( getEffectiveEnvironment ) +import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.BuildPaths ( defaultDistPref, exeExtension ) import Distribution.Simple.Command @@ -59,7 +62,7 @@ import Distribution.Simple.Program.GHC ( GhcMode(..), GhcOptions(..), renderGhcOptions ) import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Client.Config ( defaultCabalDir ) import Distribution.Client.IndexUtils @@ -74,10 +77,16 @@ , copyFileVerbose, rewriteFile, intercalate ) import Distribution.Client.Utils ( inDir, tryCanonicalizePath - , existsAndIsMoreRecentThan, moreRecentFile ) + , existsAndIsMoreRecentThan, moreRecentFile +#if mingw32_HOST_OS + , canonicalizePathNoThrow +#endif + ) import Distribution.System ( Platform(..), buildPlatform ) import Distribution.Text ( display ) +import Distribution.Utils.NubList + ( toNubListR ) import Distribution.Verbosity ( Verbosity ) import Distribution.Compat.Exception @@ -95,18 +104,39 @@ import Data.Monoid ( mempty ) import Data.Char ( isSpace ) +#ifdef mingw32_HOST_OS +import Distribution.Simple.Utils + ( withTempDirectory ) + +import Control.Exception ( bracket ) +import System.FilePath ( equalFilePath, takeDirectory ) +import System.Directory ( doesDirectoryExist ) +import qualified System.Win32 as Win32 +#endif + data SetupScriptOptions = SetupScriptOptions { useCabalVersion :: VersionRange, useCompiler :: Maybe Compiler, usePlatform :: Maybe Platform, usePackageDB :: PackageDBStack, - usePackageIndex :: Maybe PackageIndex, + usePackageIndex :: Maybe InstalledPackageIndex, useProgramConfig :: ProgramConfiguration, useDistPref :: FilePath, useLoggingHandle :: Maybe Handle, useWorkingDir :: Maybe FilePath, forceExternalSetupMethod :: Bool, + -- Used only by 'cabal clean' on Windows. + -- + -- Note: win32 clean hack + ------------------------- + -- On Windows, running './dist/setup/setup clean' doesn't work because the + -- setup script will try to delete itself (which causes it to fail horribly, + -- unlike on Linux). So we have to move the setup exe out of the way first + -- and then delete it manually. This applies only to the external setup + -- method. + useWin32CleanHack :: Bool, + -- Used only when calling setupWrapper from parallel code to serialise -- access to the setup cache; should be Nothing otherwise. -- @@ -133,6 +163,7 @@ useDistPref = defaultDistPref, useLoggingHandle = Nothing, useWorkingDir = Nothing, + useWin32CleanHack = False, forceExternalSetupMethod = False, setupCacheLock = Nothing } @@ -232,11 +263,12 @@ setupVersionFile = setupDir "setup" <.> "version" setupHs = setupDir "setup" <.> "hs" setupProgFile = setupDir "setup" <.> exeExtension + platform = fromMaybe buildPlatform (usePlatform options) useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make) maybeGetInstalledPackages :: SetupScriptOptions -> Compiler - -> ProgramConfiguration -> IO PackageIndex + -> ProgramConfiguration -> IO InstalledPackageIndex maybeGetInstalledPackages options' comp conf = case usePackageIndex options' of Just index -> return index @@ -321,6 +353,8 @@ installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramConfiguration -> IO (Version, Maybe InstalledPackageId ,SetupScriptOptions) + installedCabalVersion options' _ _ | packageName pkg == PackageName "Cabal" = + return (packageVersion pkg, Nothing, options') installedCabalVersion options' compiler conf = do index <- maybeGetInstalledPackages options' compiler conf let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options') @@ -374,7 +408,7 @@ (useProgramConfig options') verbosity return (comp, conf) -- Whenever we need to call configureCompiler, we also need to access the - -- package index, so let's cache it here. + -- package index, so let's cache it in SetupScriptOptions. index <- maybeGetInstalledPackages options' comp conf return (comp, conf, options' { useCompiler = Just comp, usePackageIndex = Just index, @@ -400,8 +434,7 @@ compilerVersionString = display $ fromMaybe buildCompilerId (fmap compilerId . useCompiler $ options') - platformString = display $ - fromMaybe buildPlatform (usePlatform options') + platformString = display platform -- | Look up the setup executable in the cache; update the cache if the setup -- executable is not found. @@ -428,13 +461,17 @@ cabalLibVersion maybeCabalLibInstalledPkgId True createDirectoryIfMissingVerbose verbosity True setupCacheDir installExecutableFile verbosity src cachedSetupProgFile + -- Do not strip if we're using GHCJS, since the result may be a script + when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $ + Strip.stripExe verbosity platform (useProgramConfig options') + cachedSetupProgFile return cachedSetupProgFile where criticalSection' = fromMaybe id (fmap criticalSection $ setupCacheLock options') -- | If the Setup.hs is out of date wrt the executable then recompile it. - -- Currently this is GHC only. It should really be generalised. + -- Currently this is GHC/GHCJS only. It should really be generalised. -- compileSetupExecutable :: SetupScriptOptions -> Version -> Maybe InstalledPackageId -> Bool @@ -448,29 +485,31 @@ debug verbosity "Setup executable needs to be updated, compiling..." (compiler, conf, options'') <- configureCompiler options' let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion - let ghcOptions = mempty { + (program, extraOpts) + = case compilerFlavor compiler of + GHCJS -> (ghcjsProgram, ["-build-runner"]) + _ -> (ghcProgram, ["-threaded"]) + ghcOptions = mempty { ghcOptVerbosity = Flag verbosity , ghcOptMode = Flag GhcModeMake - , ghcOptInputFiles = [setupHs] + , ghcOptInputFiles = toNubListR [setupHs] , ghcOptOutputFile = Flag setupProgFile , ghcOptObjDir = Flag setupDir , ghcOptHiDir = Flag setupDir , ghcOptSourcePathClear = Flag True - , ghcOptSourcePath = case bt of - Custom -> [workingDir] - _ -> [] + , ghcOptSourcePath = toNubListR [workingDir] , ghcOptPackageDBs = usePackageDB options'' - , ghcOptPackages = maybe [] - (\ipkgid -> [(ipkgid, cabalPkgid)]) - maybeCabalLibInstalledPkgId - , ghcOptExtra = ["-threaded"] + , ghcOptPackages = toNubListR $ + maybe [] (\ipkgid -> [(ipkgid, cabalPkgid, defaultRenaming)]) + maybeCabalLibInstalledPkgId + , ghcOptExtra = toNubListR extraOpts } let ghcCmdLine = renderGhcOptions compiler ghcOptions case useLoggingHandle options of - Nothing -> runDbProgram verbosity ghcProgram conf ghcCmdLine + Nothing -> runDbProgram verbosity program conf ghcCmdLine -- If build logging is enabled, redirect compiler output to the log file. - (Just logHandle) -> do output <- getDbProgramOutput verbosity ghcProgram + (Just logHandle) -> do output <- getDbProgramOutput verbosity program conf ghcCmdLine hPutStr logHandle output return setupProgFile @@ -489,12 +528,48 @@ -- working directory. path' <- tryCanonicalizePath path - searchpath <- programSearchPathAsPATHVar - (getProgramSearchPath (useProgramConfig options')) - env <- getEffectiveEnvironment [("PATH", Just searchpath)] + -- See 'Note: win32 clean hack' above. +#if mingw32_HOST_OS + -- setupProgFile may not exist if we're using a cached program + setupProgFile' <- canonicalizePathNoThrow setupProgFile + let win32CleanHackNeeded = (useWin32CleanHack options') + -- Skip when a cached setup script is used. + && setupProgFile' `equalFilePath` path' + if win32CleanHackNeeded then doWin32CleanHack path' else doInvoke path' +#else + doInvoke path' +#endif - process <- runProcess path' args - (useWorkingDir options') env - Nothing (useLoggingHandle options') (useLoggingHandle options') - exitCode <- waitForProcess process - unless (exitCode == ExitSuccess) $ exitWith exitCode + where + doInvoke path' = do + searchpath <- programSearchPathAsPATHVar + (getProgramSearchPath (useProgramConfig options')) + env <- getEffectiveEnvironment [("PATH", Just searchpath)] + + process <- runProcess path' args + (useWorkingDir options') env Nothing + (useLoggingHandle options') (useLoggingHandle options') + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode + +#if mingw32_HOST_OS + doWin32CleanHack path' = do + info verbosity $ "Using the Win32 clean hack." + -- Recursively removes the temp dir on exit. + withTempDirectory verbosity workingDir "cabal-tmp" $ \tmpDir -> + bracket (moveOutOfTheWay tmpDir path') + (maybeRestore path') + doInvoke + + moveOutOfTheWay tmpDir path' = do + let newPath = tmpDir "setup" <.> exeExtension + Win32.moveFile path' newPath + return newPath + + maybeRestore oldPath path' = do + let oldPathDir = takeDirectory oldPath + oldPathDirExists <- doesDirectoryExist oldPathDir + -- 'setup clean' didn't complete, 'dist/setup' still exists. + when oldPathDirExists $ + Win32.moveFile path' oldPath +#endif diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs --- a/Distribution/Client/Tar.hs +++ b/Distribution/Client/Tar.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | @@ -673,13 +674,11 @@ . getBytes off len data Partial a = Error String | Ok a + deriving Functor partial :: Partial a -> Either String a partial (Error msg) = Left msg partial (Ok x) = Right x - -instance Functor Partial where - fmap = liftM instance Applicative Partial where pure = return diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -58,6 +58,7 @@ import qualified Distribution.Client.PackageIndex as PackageIndex import qualified Distribution.Client.Tar as Tar import Distribution.Client.FetchUtils +import Distribution.Client.Utils ( tryFindPackageDesc ) import Distribution.PackageDescription ( GenericPackageDescription, FlagName(..), FlagAssignment ) @@ -70,7 +71,7 @@ ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils - ( die, warn, intercalate, tryFindPackageDesc, fromUTF8, lowercase ) + ( die, warn, intercalate, fromUTF8, lowercase ) import Data.List ( find, nub ) @@ -422,7 +423,7 @@ UserTargetLocalCabalFile file -> do let dir = takeDirectory file - _ <- tryFindPackageDesc dir -- just as a check + _ <- tryFindPackageDesc dir (localPackageError dir) -- just as a check return [ PackageTargetLocation (LocalUnpackedPackage dir) ] UserTargetLocalTarball tarballFile -> @@ -431,6 +432,9 @@ UserTargetRemoteTarball tarballURL -> return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] +localPackageError :: FilePath -> String +localPackageError dir = + "Error reading local package.\nCouldn't find .cabal file in: " ++ dir -- ------------------------------------------------------------ -- * Fetching and reading package targets @@ -468,7 +472,8 @@ PackageTargetLocation location -> case location of LocalUnpackedPackage dir -> do - pkg <- readPackageDescription verbosity =<< tryFindPackageDesc dir + pkg <- tryFindPackageDesc dir (localPackageError dir) >>= + readPackageDescription verbosity return $ PackageTargetLocation $ SourcePackage { packageInfoId = packageId pkg, diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Types @@ -14,9 +15,11 @@ module Distribution.Client.Types where import Distribution.Package - ( PackageName, PackageId, Package(..), PackageFixedDeps(..) ) + ( PackageName, PackageId, Package(..), PackageFixedDeps(..) + , mkPackageKey, PackageKey, InstalledPackageId(..) + , PackageInstalled(..) ) import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) + ( InstalledPackageInfo, packageKey ) import Distribution.PackageDescription ( Benchmark(..), GenericPackageDescription(..), FlagAssignment , TestSuite(..) ) @@ -26,6 +29,9 @@ ( PackageIndex ) import Distribution.Version ( VersionRange ) +import Distribution.Simple.Compiler + ( Compiler, packageKeySupported ) +import Distribution.Text (display) import Data.Map (Map) import Network.URI (URI) @@ -69,7 +75,23 @@ packageId (InstalledPackage pkg _) = packageId pkg instance PackageFixedDeps InstalledPackage where depends (InstalledPackage _ deps) = deps +instance PackageInstalled InstalledPackage where + installedPackageId (InstalledPackage pkg _) = installedPackageId pkg + installedDepends (InstalledPackage pkg _) = installedDepends pkg + +-- | In order to reuse the implementation of PackageIndex which relies on +-- 'InstalledPackageId', we need to be able to synthesize these IDs prior +-- to installation. Eventually, we'll move to a representation of +-- 'InstalledPackageId' which can be properly computed before compilation +-- (of course, it's a bit of a misnomer since the packages are not actually +-- installed yet.) In any case, we'll synthesize temporary installed package +-- IDs to use as keys during install planning. These should never be written +-- out! Additionally, they need to be guaranteed unique within the install +-- plan. +fakeInstalledPackageId :: PackageId -> InstalledPackageId +fakeInstalledPackageId = InstalledPackageId . (".fake."++) . display + -- | A 'ConfiguredPackage' is a not-yet-installed package along with the -- total configuration information. The configuration information is total in -- the sense that it provides all the configuration information and so the @@ -91,6 +113,10 @@ instance PackageFixedDeps ConfiguredPackage where depends (ConfiguredPackage _ _ _ deps) = deps +instance PackageInstalled ConfiguredPackage where + installedPackageId = fakeInstalledPackageId . packageId + installedDepends = map fakeInstalledPackageId . depends + -- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be -- installed already, hence itself ready to be installed. data ReadyPackage = ReadyPackage @@ -106,6 +132,18 @@ instance PackageFixedDeps ReadyPackage where depends (ReadyPackage _ _ _ deps) = map packageId deps +instance PackageInstalled ReadyPackage where + installedPackageId = fakeInstalledPackageId . packageId + installedDepends (ReadyPackage _ _ _ ipis) = map installedPackageId ipis + +-- | Extracts a package key from ReadyPackage, a common operation needed +-- to calculate build paths. +readyPackageKey :: Compiler -> ReadyPackage -> PackageKey +readyPackageKey comp (ReadyPackage pkg _ _ deps) = + mkPackageKey (packageKeySupported comp) (packageId pkg) + (map packageKey deps) [] + + -- | Sometimes we need to convert a 'ReadyPackage' back to a -- 'ConfiguredPackage'. For example, a failed 'PlanPackage' can be *either* -- Ready or Configured. @@ -172,14 +210,7 @@ --TODO: -- * add support for darcs and other SCM style remote repos with a local cache -- | ScmPackage - deriving Show - -instance Functor PackageLocation where - fmap _ (LocalUnpackedPackage dir) = LocalUnpackedPackage dir - fmap _ (LocalTarballPackage file) = LocalTarballPackage file - fmap f (RemoteTarballPackage uri x) = RemoteTarballPackage uri (f x) - fmap f (RepoTarballPackage repo pkg x) = RepoTarballPackage repo pkg (f x) - + deriving (Show, Functor) data LocalRepo = LocalRepo deriving (Show,Eq) @@ -188,7 +219,7 @@ remoteRepoName :: String, remoteRepoURI :: URI } - deriving (Show,Eq) + deriving (Show,Eq,Ord) data Repo = Repo { repoKind :: Either RemoteRepo LocalRepo, @@ -201,7 +232,8 @@ -- ------------------------------------------------------------ type BuildResult = Either BuildFailure BuildSuccess -data BuildFailure = DependentFailed PackageId +data BuildFailure = PlanningFailed + | DependentFailed PackageId | DownloadFailed SomeException | UnpackFailed SomeException | ConfigureFailed SomeException diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -15,21 +15,14 @@ ) where import Distribution.Client.Types - ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) ) + ( Repo(..), RemoteRepo(..), LocalRepo(..) ) import Distribution.Client.HttpUtils ( DownloadResult(..) ) import Distribution.Client.FetchUtils ( downloadIndex ) -import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.IndexUtils - ( getSourcePackages, updateRepoIndexCache ) -import qualified Paths_cabal_install - ( version ) + ( updateRepoIndexCache ) -import Distribution.Package - ( PackageName(..), packageVersion ) -import Distribution.Version - ( anyVersion, withinRange ) import Distribution.Simple.Utils ( writeFileAtomic, warn, notice ) import Distribution.Verbosity @@ -37,10 +30,7 @@ import qualified Data.ByteString.Lazy as BS import Distribution.Client.GZipUtils (maybeDecompress) -import qualified Data.Map as Map import System.FilePath (dropExtension) -import Data.Maybe (fromMaybe) -import Control.Monad (unless) -- | 'update' downloads the package list from all known servers update :: Verbosity -> [Repo] -> IO () @@ -49,7 +39,6 @@ ++ "you would have one specified in the config file." update verbosity repos = do mapM_ (updateRepo verbosity) repos - checkForSelfUpgrade verbosity repos updateRepo :: Verbosity -> Repo -> IO () updateRepo verbosity repo = case repoKind repo of @@ -64,22 +53,3 @@ writeFileAtomic (dropExtension indexPath) . maybeDecompress =<< BS.readFile indexPath updateRepoIndexCache verbosity repo - -checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () -checkForSelfUpgrade verbosity repos = do - SourcePackageDb sourcePkgIndex prefs <- getSourcePackages verbosity repos - - let self = PackageName "cabal-install" - preferredVersionRange = fromMaybe anyVersion (Map.lookup self prefs) - currentVersion = Paths_cabal_install.version - laterPreferredVersions = - [ packageVersion pkg - | pkg <- PackageIndex.lookupPackageName sourcePkgIndex self - , let version = packageVersion pkg - , version > currentVersion - , version `withinRange` preferredVersionRange ] - - unless (null laterPreferredVersions) $ - notice verbosity $ - "Note: there is a new version of cabal-install available.\n" - ++ "To upgrade, run: cabal install cabal-install" diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -18,10 +18,12 @@ import qualified Distribution.Client.BuildReports.Upload as BuildReport import Network.Browser - ( request ) + ( BrowserAction, request + , Authority(..), addAuthority ) import Network.HTTP ( Header(..), HeaderName(..), findHeader , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) import Network.URI (URI(uriPath), parseURI) import Data.Char (intToDigit) @@ -51,7 +53,12 @@ else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"} Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword - let auth = Just (username, password) + let auth = addAuthority AuthBasic { + auRealm = "Hackage", + auUsername = username, + auPassword = password, + auSite = uploadURI + } flip mapM_ paths $ \path -> do notice verbosity $ "Uploading " ++ path ++ "... " handlePackage verbosity uploadURI auth path @@ -77,9 +84,17 @@ report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO () report verbosity repos mUsername mPassword = do + let uploadURI = if isOldHackageURI targetRepoURI + then legacyUploadURI + else targetRepoURI{uriPath = ""} Username username <- maybe promptUsername return mUsername Password password <- maybe promptPassword return mPassword - let auth = Just (username, password) + let auth = addAuthority AuthBasic { + auRealm = "Hackage", + auUsername = username, + auPassword = password, + auSite = uploadURI + } forM_ repos $ \repo -> case repoKind repo of Left remoteRepo -> do dotCabal <- defaultCabalDir @@ -98,14 +113,16 @@ cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] return () Right{} -> return () + where + targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given check :: Verbosity -> [FilePath] -> IO () check verbosity paths = do flip mapM_ paths $ \path -> do notice verbosity $ "Checking " ++ path ++ "... " - handlePackage verbosity checkURI Nothing path + handlePackage verbosity checkURI (return ()) path -handlePackage :: Verbosity -> URI -> Maybe (String, String) +handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream ByteString) () -> FilePath -> IO () handlePackage verbosity uri auth path = do req <- mkRequest uri path diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs --- a/Distribution/Client/Utils.hs +++ b/Distribution/Client/Utils.hs @@ -7,12 +7,16 @@ , makeAbsoluteToCwd, filePathToByteString , byteStringToFilePath, tryCanonicalizePath , canonicalizePathNoThrow - , moreRecentFile, existsAndIsMoreRecentThan ) + , moreRecentFile, existsAndIsMoreRecentThan + , tryFindAddSourcePackageDesc + , tryFindPackageDesc + , relaxEncodingErrors) where import Distribution.Compat.Exception ( catchIO ) import Distribution.Client.Compat.Time ( getModTime ) import Distribution.Simple.Setup ( Flag(..) ) +import Distribution.Simple.Utils ( die, findPackageDesc ) import qualified Data.ByteString.Lazy as BS import Control.Monad ( when ) @@ -21,7 +25,7 @@ import Data.Char ( ord, chr ) import Data.List - ( sortBy, groupBy ) + ( isPrefixOf, sortBy, groupBy ) import Data.Word ( Word8, Word32) import Foreign.C.Types ( CInt(..) ) @@ -32,8 +36,21 @@ , removeFile, setCurrentDirectory ) import System.FilePath ( (), isAbsolute ) +import System.IO + ( Handle +#if MIN_VERSION_base(4,4,0) + , hGetEncoding, hSetEncoding +#endif + ) import System.IO.Unsafe ( unsafePerformIO ) +#if MIN_VERSION_base(4,4,0) +import GHC.IO.Encoding + ( recover, TextEncoding(TextEncoding) ) +import GHC.IO.Encoding.Failure + ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) +#endif + #if defined(mingw32_HOST_OS) import Prelude hiding (ioError) import Control.Monad (liftM2, unless) @@ -185,3 +202,36 @@ if not exists then return False else a `moreRecentFile` b + +-- | Sets the handler for encoding errors to one that transliterates invalid +-- characters into one present in the encoding (i.e., \'?\'). +-- This is opposed to the default behavior, which is to throw an exception on +-- error. This function will ignore file handles that have a Unicode encoding +-- set. It's a no-op for versions of `base` less than 4.4. +relaxEncodingErrors :: Handle -> IO () +relaxEncodingErrors handle = do +#if MIN_VERSION_base(4,4,0) + maybeEncoding <- hGetEncoding handle + case maybeEncoding of + Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) -> + let relax x = x { recover = recoverEncode TransliterateCodingFailure } + in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder)) + _ -> +#endif + return () + +-- |Like 'tryFindPackageDesc', but with error specific to add-source deps. +tryFindAddSourcePackageDesc :: FilePath -> String -> IO FilePath +tryFindAddSourcePackageDesc depPath err = tryFindPackageDesc depPath $ + err ++ "\n" ++ "Failed to read cabal file of add-source dependency: " + ++ depPath + +-- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be +-- found, with @err@ prefixing the error message. This function simply allows +-- us to give a more descriptive error than that provided by @findPackageDesc@. +tryFindPackageDesc :: FilePath -> String -> IO FilePath +tryFindPackageDesc depPath err = do + errOrCabalFile <- findPackageDesc depPath + case errOrCabalFile of + Right file -> return file + Left _ -> die err diff --git a/Distribution/Client/Win32SelfUpgrade.hs b/Distribution/Client/Win32SelfUpgrade.hs --- a/Distribution/Client/Win32SelfUpgrade.hs +++ b/Distribution/Client/Win32SelfUpgrade.hs @@ -42,10 +42,9 @@ deleteOldExeFile, ) where -#if mingw32_HOST_OS || mingw32_TARGET_OS +#if mingw32_HOST_OS import qualified System.Win32 as Win32 -import qualified System.Win32.DLL as Win32 import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) import Foreign.Ptr (Ptr, nullPtr) import System.Process (runProcess) @@ -161,10 +160,16 @@ -- A bunch of functions sadly not provided by the Win32 package. -foreign import stdcall unsafe "windows.h GetCurrentProcessId" +#ifdef x86_64_HOST_ARCH +#define CALLCONV ccall +#else +#define CALLCONV stdcall +#endif + +foreign import CALLCONV unsafe "windows.h GetCurrentProcessId" getCurrentProcessId :: IO DWORD -foreign import stdcall unsafe "windows.h WaitForSingleObject" +foreign import CALLCONV unsafe "windows.h WaitForSingleObject" waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD waitForSingleObject :: HANDLE -> DWORD -> IO () @@ -175,7 +180,7 @@ bad result = not (result == 0 || result == wAIT_TIMEOUT) wAIT_TIMEOUT = 0x00000102 -foreign import stdcall unsafe "windows.h CreateEventW" +foreign import CALLCONV unsafe "windows.h CreateEventW" createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE createEvent :: String -> IO HANDLE @@ -184,7 +189,7 @@ Win32.withTString name $ createEvent_ nullPtr False False -foreign import stdcall unsafe "windows.h OpenEventW" +foreign import CALLCONV unsafe "windows.h OpenEventW" openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE openEvent :: String -> IO HANDLE @@ -196,7 +201,7 @@ eVENT_MODIFY_STATE :: DWORD eVENT_MODIFY_STATE = 0x0002 -foreign import stdcall unsafe "windows.h SetEvent" +foreign import CALLCONV unsafe "windows.h SetEvent" setEvent_ :: HANDLE -> IO BOOL setEvent :: HANDLE -> IO () diff --git a/Distribution/Client/World.hs b/Distribution/Client/World.hs --- a/Distribution/Client/World.hs +++ b/Distribution/Client/World.hs @@ -49,8 +49,6 @@ import Data.List ( unionBy, deleteFirstsBy, nubBy ) -import Data.Maybe - ( isJust, fromJust ) import System.IO.Error ( isDoesNotExistError ) import qualified Data.ByteString.Lazy.Char8 as B @@ -113,9 +111,9 @@ getContents world = do content <- safelyReadFile world let result = map simpleParse (lines $ B.unpack content) - if all isJust result - then return $ map fromJust result - else die "Could not parse world file." + case sequence result of + Nothing -> die "Could not parse world file." + Just xs -> return xs where safelyReadFile :: FilePath -> IO B.ByteString safelyReadFile file = B.readFile file `catchIO` handler diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Main @@ -18,7 +20,7 @@ , ConfigFlags(..) , ConfigExFlags(..), defaultConfigExFlags, configureExCommand , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) - , buildCommand, testCommand, benchmarkCommand + , buildCommand, replCommand, testCommand, benchmarkCommand , InstallFlags(..), defaultInstallFlags , installCommand, upgradeCommand , FetchFlags(..), fetchCommand @@ -37,12 +39,13 @@ , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand , SandboxFlags(..), sandboxCommand , ExecFlags(..), execCommand + , UserConfigFlags(..), userConfigCommand , reportCommand ) import Distribution.Simple.Setup ( HaddockFlags(..), haddockCommand, defaultHaddockFlags , HscolourFlags(..), hscolourCommand - , ReplFlags(..), replCommand + , ReplFlags(..) , CopyFlags(..), copyCommand , RegisterFlags(..), registerCommand , CleanFlags(..), cleanCommand @@ -54,7 +57,8 @@ import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) import Distribution.Client.Config - ( SavedConfig(..), loadConfig, defaultConfigFile ) + ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff + , userConfigUpdate ) import Distribution.Client.Targets ( readUserTargets ) import qualified Distribution.Client.List as List @@ -63,6 +67,7 @@ import Distribution.Client.Install (install) import Distribution.Client.Configure (configure) import Distribution.Client.Update (update) +import Distribution.Client.Exec (exec) import Distribution.Client.Fetch (fetch) import Distribution.Client.Freeze (freeze) import Distribution.Client.Check as Check (check) @@ -78,7 +83,6 @@ ,sandboxListSources ,sandboxHcPkg ,dumpPackageEnvironment - ,withSandboxBinDirOnSearchPath ,getSandboxConfigFilePath ,loadConfigOrSandboxConfig @@ -95,17 +99,19 @@ ,configPackageDB') import Distribution.Client.Sandbox.PackageEnvironment (setPackageDB - ,sandboxPackageDBPath ,userPackageEnvironmentFile) import Distribution.Client.Sandbox.Timestamp (maybeAddCompilerTimestampRecord) import Distribution.Client.Sandbox.Types (UseSandbox(..), whenUsingSandbox) import Distribution.Client.Init (initCabal) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import Distribution.Client.Utils (determineNumJobs +#if defined(mingw32_HOST_OS) + ,relaxEncodingErrors +#endif ,existsAndIsMoreRecentThan) import Distribution.PackageDescription - ( Executable(..) ) + ( Executable(..), benchmarkName, testName ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.PackageDescription.PrettyPrint @@ -119,17 +125,15 @@ ( Compiler(..) ) import Distribution.Simple.Configure ( checkPersistBuildConfigOutdated, configCompilerAuxEx - , ConfigStateFileErrorType(..), localBuildInfoFile + , ConfigStateFileError(..), localBuildInfoFile , getPersistBuildConfig, tryGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.GHC (ghcGlobalPackageDB) -import Distribution.Simple.Program (defaultProgramConfiguration, lookupProgram, ghcProgram) -import Distribution.Simple.Program.Run (getEffectiveEnvironment) +import Distribution.Simple.Program (defaultProgramConfiguration + ,configureAllKnownPrograms) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils - ( cabalVersion, debug, die, notice, info, topHandler - , findPackageDesc, tryFindPackageDesc , rawSystemExit - , rawSystemExitWithEnv ) + ( cabalVersion, die, notice, info, topHandler + , findPackageDesc, tryFindPackageDesc ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity @@ -140,11 +144,15 @@ import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) -import System.FilePath (splitExtension, takeExtension, searchPathSeparator) -import System.IO (BufferMode(LineBuffering), - hSetBuffering, stdout) +import System.FilePath (splitExtension, takeExtension) +import System.IO ( BufferMode(LineBuffering), hSetBuffering +#ifdef mingw32_HOST_OS + , stderr +#endif + , stdout ) import System.Directory (doesFileExist, getCurrentDirectory) import Data.List (intercalate) +import Data.Maybe (mapMaybe) import Data.Monoid (Monoid(..)) import Control.Monad (when, unless) @@ -155,11 +163,18 @@ -- Enable line buffering so that we can get fast feedback even when piped. -- This is especially important for CI and build systems. hSetBuffering stdout LineBuffering + -- The default locale encoding for Windows CLI is not UTF-8 and printing + -- Unicode characters to it will fail unless we relax the handling of encoding + -- errors when writing to stderr and stdout. +#ifdef mingw32_HOST_OS + relaxEncodingErrors stdout + relaxEncodingErrors stderr +#endif getArgs >>= mainWorker mainWorker :: [String] -> IO () mainWorker args = topHandler $ - case commandsRun globalCommand commands args of + case commandsRun (globalCommand commands) commands args of CommandHelp help -> printGlobalHelp help CommandList opts -> printOptionsList opts CommandErrors errs -> printErrors errs @@ -217,15 +232,14 @@ ,initCommand `commandAddAction` initAction ,configureExCommand `commandAddAction` configureAction ,buildCommand `commandAddAction` buildAction - ,replCommand defaultProgramConfiguration - `commandAddAction` replAction + ,replCommand `commandAddAction` replAction ,sandboxCommand `commandAddAction` sandboxAction ,haddockCommand `commandAddAction` haddockAction ,execCommand `commandAddAction` execAction + ,userConfigCommand `commandAddAction` userConfigAction + ,cleanCommand `commandAddAction` cleanAction ,wrapperAction copyCommand copyVerbosity copyDistPref - ,wrapperAction cleanCommand - cleanVerbosity cleanDistPref ,wrapperAction hscolourCommand hscolourVerbosity hscolourDistPref ,wrapperAction registerCommand @@ -348,8 +362,8 @@ numJobsCmdLineFlag = buildNumJobs buildFlags -replAction :: ReplFlags -> [String] -> GlobalFlags -> IO () -replAction replFlags extraArgs globalFlags = do +replAction :: (ReplFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO () +replAction (replFlags, buildExFlags) extraArgs globalFlags = do cwd <- getCurrentDirectory pkgDesc <- findPackageDesc cwd either (const onNoPkgDesc) (const onPkgDesc) pkgDesc @@ -362,8 +376,9 @@ let distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions) (replDistPref replFlags) noAddSource = case replReload replFlags of - Flag True -> SkipAddSourceDepsCheck - _ -> DontSkipAddSourceDepsCheck + Flag True -> SkipAddSourceDepsCheck + _ -> fromFlagOrDefault DontSkipAddSourceDepsCheck + (buildOnly buildExFlags) progConf = defaultProgramConfiguration setupOptions = defaultSetupScriptOptions { useCabalVersion = orLaterVersion $ Version [1,18,0] [] @@ -454,8 +469,8 @@ skipAddSourceDepsCheck numJobsFlag checkFlags = do eLbi <- tryGetPersistBuildConfig distPref case eLbi of - Left (err, errCode) -> onNoBuildConfig err errCode - Right lbi -> onBuildConfig lbi + Left err -> onNoBuildConfig err + Right lbi -> onBuildConfig lbi where @@ -463,17 +478,16 @@ -- -- If we're in a sandbox: add-source deps don't have to be reinstalled -- (since we don't know the compiler & platform). - onNoBuildConfig :: String -> ConfigStateFileErrorType - -> IO (UseSandbox, SavedConfig) - onNoBuildConfig err errCode = do - let msg = case errCode of - ConfigStateFileMissing -> "Package has never been configured." - ConfigStateFileCantParse -> "Saved package config file seems " - ++ "to be corrupt." - ConfigStateFileBadVersion -> err - case errCode of - ConfigStateFileBadVersion -> info verbosity msg - _ -> do + onNoBuildConfig :: ConfigStateFileError -> IO (UseSandbox, SavedConfig) + onNoBuildConfig err = do + let msg = case err of + ConfigStateFileMissing -> "Package has never been configured." + ConfigStateFileNoParse -> "Saved package config file seems " + ++ "to be corrupt." + _ -> show err + case err of + ConfigStateFileBadVersion _ _ _ -> info verbosity msg + _ -> do notice verbosity $ msg ++ " Configuring with default flags." ++ configureManually configureAction (defaultFlags, defaultConfigExFlags) @@ -647,6 +661,8 @@ savedHaddockFlags config `mappend` haddockFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, conf) <- configCompilerAux' configFlags' + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the future. + conf' <- configureAllKnownPrograms verbosity conf -- If we're working inside a sandbox and the user has set the -w option, we -- may need to create a sandbox-local package DB for this compiler and add a @@ -659,7 +675,7 @@ } whenUsingSandbox useSandbox $ \sandboxDir -> do - initPackageDBIfNeeded verbosity configFlags'' comp conf + initPackageDBIfNeeded verbosity configFlags'' comp conf' indexFile <- tryGetIndexFilePath config maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile @@ -676,7 +692,7 @@ install verbosity (configPackageDB' configFlags'') (globalRepos globalFlags') - comp platform conf + comp platform conf' useSandbox mSandboxPkgInfo globalFlags' configFlags'' configExFlags' installFlags' haddockFlags' @@ -711,12 +727,24 @@ globalFlags noAddSource (buildNumJobs buildFlags') checkFlags + -- the package was just configured, so the LBI must be available + lbi <- getPersistBuildConfig distPref + let pkgDescr = LBI.localPkgDescr lbi + nameTestsOnly = LBI.foldComponent (const Nothing) + (const Nothing) + (Just . testName) + (const Nothing) + tests = mapMaybe nameTestsOnly $ LBI.pkgComponents pkgDescr + extraArgs' + | null extraArgs = tests + | otherwise = extraArgs + maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config distPref buildFlags' extraArgs + build verbosity config distPref buildFlags' extraArgs' maybeWithSandboxDirOnSearchPath useSandbox $ setupWrapper verbosity setupOptions Nothing - Cabal.testCommand (const testFlags) extraArgs + Cabal.testCommand (const testFlags) extraArgs' benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags @@ -744,12 +772,24 @@ globalFlags noAddSource (buildNumJobs buildFlags') checkFlags + -- the package was just configured, so the LBI must be available + lbi <- getPersistBuildConfig distPref + let pkgDescr = LBI.localPkgDescr lbi + nameBenchsOnly = LBI.foldComponent (const Nothing) + (const Nothing) + (const Nothing) + (Just . benchmarkName) + benchs = mapMaybe nameBenchsOnly $ LBI.pkgComponents pkgDescr + extraArgs' + | null extraArgs = benchs + | otherwise = extraArgs + maybeWithSandboxDirOnSearchPath useSandbox $ - build verbosity config distPref buildFlags' extraArgs + build verbosity config distPref buildFlags' extraArgs' maybeWithSandboxDirOnSearchPath useSandbox $ setupWrapper verbosity setupOptions Nothing - Cabal.benchmarkCommand (const benchmarkFlags) extraArgs + Cabal.benchmarkCommand (const benchmarkFlags) extraArgs' haddockAction :: HaddockFlags -> [String] -> GlobalFlags -> IO () haddockAction haddockFlags extraArgs globalFlags = do @@ -765,6 +805,19 @@ setupWrapper verbosity setupScriptOptions Nothing haddockCommand (const haddockFlags') extraArgs +cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO () +cleanAction cleanFlags extraArgs _globalFlags = + setupWrapper verbosity setupScriptOptions Nothing + cleanCommand (const cleanFlags) extraArgs + where + verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) + setupScriptOptions = defaultSetupScriptOptions { + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (cleanDistPref cleanFlags), + useWin32CleanHack = True + } + listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do let verbosity = fromFlag (listVerbosity listFlags) @@ -993,6 +1046,12 @@ when (noExtraArgs extra) $ die "The 'sandbox add-source' command expects at least one argument" sandboxAddSource verbosity extra sandboxFlags globalFlags + ("delete-source":extra) -> do + when (noExtraArgs extra) $ + die "The 'sandbox delete-source' command expects \ + \at least one argument" + sandboxDeleteSource verbosity extra sandboxFlags globalFlags + ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags -- More advanced commands. ("hc-pkg":extra) -> do @@ -1002,12 +1061,6 @@ ["buildopts"] -> die "Not implemented!" -- Hidden commands. - ("delete-source":extra) -> do - when (noExtraArgs extra) $ - die "The 'sandbox delete-source' command expects \ - \at least one argument" - sandboxDeleteSource verbosity extra sandboxFlags globalFlags - ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags ["dump-pkgenv"] -> dumpPackageEnvironment verbosity sandboxFlags globalFlags -- Error handling. @@ -1022,32 +1075,20 @@ let verbosity = fromFlag (execVerbosity execFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty + let configFlags = savedConfigureFlags config + (comp, platform, conf) <- configCompilerAux' configFlags + exec verbosity useSandbox comp platform conf extraArgs + +userConfigAction :: UserConfigFlags -> [String] -> GlobalFlags -> IO () +userConfigAction ucflags extraArgs globalFlags = do + let verbosity = fromFlag (userConfigVerbosity ucflags) case extraArgs of - (exec:args) -> do - case useSandbox of - NoSandbox -> - rawSystemExit verbosity exec args - (UseSandbox sandboxDir) -> do - let configFlags = savedConfigureFlags config - (comp, platform, conf) <- configCompilerAux' configFlags - withSandboxBinDirOnSearchPath sandboxDir $ do - menv <- newEnv sandboxDir comp platform conf verbosity - case menv of - Just env -> rawSystemExitWithEnv verbosity exec args env - Nothing -> rawSystemExit verbosity exec args + ("diff":_) -> mapM_ putStrLn =<< userConfigDiff globalFlags + ("update":_) -> userConfigUpdate verbosity globalFlags -- Error handling. - [] -> die $ "Please specify an executable to run" - where - newEnv sandboxDir comp platform conf verbosity = do - let s = sandboxPackageDBPath sandboxDir comp platform - case lookupProgram ghcProgram conf of - Nothing -> do - debug verbosity "sandbox exec only works with GHC" - exitFailure - Just ghcProg -> do - g <- ghcGlobalPackageDB verbosity ghcProg - getEffectiveEnvironment - [("GHC_PACKAGE_PATH", Just $ s ++ [searchPathSeparator] ++ g)] + [] -> die $ "Please specify a subcommand (see 'help user-config')" + _ -> die $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs + -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. -- diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,143 +0,0 @@ -The cabal-install package -========================= - -[Cabal home page](http://www.haskell.org/cabal/) - -The `cabal-install` package provides a command line tool called `cabal`. The -tool uses the `Cabal` library and provides a convenient user interface to the -Cabal/Hackage package build and distribution system. It can build and install -both local and remote packages, including dependencies. - - -Installation instructions for the cabal-install command line tool -================================================================= - -The `cabal-install` package requires a number of other packages, most of which -come with a standard ghc installation. It requires the `network` package, which -is sometimes packaged separately by Linux distributions, for example on -debian or ubuntu it is in "libghc6-network-dev". - -It requires a few other Haskell packages that are not always installed. -The exact list is specified in the `.cabal` file or in the `bootstrap.sh` -file. All these packages are available from -[Hackage](http://hackage.haskell.org). - -Note that on some Unix systems you may need to install an additional zlib -development package using your system package manager, for example on -debian or ubuntu it is in "zlib1g-dev". It is needed is because the -Haskell zlib package uses the system zlib C library and header files. - -The `cabal-install` package is now part of the Haskell Platform so you do not -usually need to install it separately. However if you are starting from a -minimal ghc installation then you need to install `cabal-install` manually. -Since it is just an ordinary Cabal package it can be built in the standard -way, but to make it a bit easier we have partly automated the process: - - -Quickstart on Unix systems --------------------------- - -As a convenience for users on Unix systems there is a `bootstrap.sh` script -which will download and install each of the dependencies in turn. - - $ ./bootstrap.sh - -It will download and install the dependencies. The script will -install the library packages into `$HOME/.cabal/` and the `cabal` program will -be installed into `$HOME/.cabal/bin/`. - -You then have two choices: - - * put `$HOME/.cabal/bin` on your `$PATH` - * move the `cabal` program somewhere that is on your `$PATH` - -The next thing to do is to get the latest list of packages with: - - $ cabal update - -This will also create a default config file (if it does not already echo exist) -at `$HOME/.cabal/config` - -By default cabal will install programs to `$HOME/.cabal/bin`. If you do not -want to add this directory to your `$PATH` then you can change the setting in -the config file, for example you could use: - - symlink-bindir: $HOME/bin - - -Quickstart on Windows systems ------------------------------ - -For Windows users we provide a pre-compiled [cabal.exe] program. Just download -it and put it somewhere on your `%PATH%`, for example -`C:\Program Files\Haskell\bin`. - -[cabal.exe]: http://haskell.org/cabal/release/cabal-install-latest/cabal.exe - -The next thing to do is to get the latest list of packages with - - cabal update - -This will also create a default config file (if it does not already echo exist) -at `C:\Documents and Settings\username\Application Data\cabal\config` - - -Using cabal-install -=================== - -There are two sets of commands: commands for working with a local project build -tree and ones for working with distributed released packages from hackage. - -For a list of the full set of commands and the flags for each command see - - $ cabal --help - - -Commands for developers for local build trees ---------------------------------------------- - -The commands for local project build trees are almost exactly the same as the -`runghc Setup` command line interface that many people are already familiar -with. In particular there are the commands - - cabal configure - cabal build - cabal haddock - cabal clean - cabal sdist - -The `install` command is somewhat different. It is an all-in-one operation. If -you run - - $ cabal install - -in your build tree it will configure, build and install. It takes all the flags -that `configure` takes such as `--global` and `--prefix`. - -In addition, if any dependencies are not installed it will download and install -them. If can also rebuild packages to ensure a consistent set of dependencies. - - -Commands for released hackage packages --------------------------------------- - - $ cabal update - -This command gets the latest list of packages from the hackage server. -Currently this command has to be run manually occasionally, in particular if -you want to install a newly released package. - - - $ cabal install xmonad - -This is the eponymous command. It installs one or more named packages (and all -their dependencies) from hackage. - -By default it installs the latest available version however you can optionally -specify exact versions or version ranges. For example `cabal install alex-2.2` -or `cabal install parsec < 3`. - - $ cabal list xml - -This does a search of the installed and available packages. It does a -case-insensitive substring match on the package name. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,155 @@ +The cabal-install package +========================= + +See the [Cabal web site] for more information. + +The `cabal-install` package provides a command line tool named `cabal`. +It uses the [Cabal] library and provides a user interface to the +Cabal/[Hackage] build automation and package management system. It can +build and install both local and remote packages, including +dependencies. + +[Cabal web site]: http://www.haskell.org/cabal/ +[Cabal]: ../Cabal/README.md + +Installing the `cabal` command-line tool +======================================== + +The `cabal-install` package requires a number of other packages, most of +which come with a standard GHC installation. It requires the [network] +package, which is sometimes packaged separately by Linux distributions; +for example, on Debian or Ubuntu, it is located in the +"libghc6-network-dev" package. + +`cabal` requires a few other Haskell packages that are not always +installed. The exact list is specified in the [.cabal] file or in the +[bootstrap.sh] file. All these packages are available from [Hackage]. + +Note that on some Unix systems you may need to install an additional +zlib development package using your system package manager; for example, +on Debian or Ubuntu, it is located in the "zlib1g-dev" package; on +Fedora, it is located in the "zlib-devel" package. It is required +because the Haskell zlib package uses the system zlib C library and +header files. + +The `cabal-install` package is now part of the [Haskell Platform], so you +do not usually need to install it separately. However, if you are +starting from a minimal GHC installation, you need to install +`cabal-install` manually. Since it is an ordinary Cabal package, +`cabal-install` can be built the standard way; to facilitate this, the +process has been partially automated. It is described below. + +[.cabal]: cabal-install.cabal +[network]: http://hackage.haskell.org/package/network +[Haskell Platform]: http://www.haskell.org/platform/ + +Quick start on Unix-like systems +-------------------------------- + +As a convenience for users on Unix-like systems, there is a +[bootstrap.sh] script that will download and install each of +`cabal-install`'s dependencies in turn. + + $ ./bootstrap.sh + +It will download and install the dependencies. The script will install the +library packages (vanilla, profiling and shared) into `$HOME/.cabal/` and the +`cabal` program into `$HOME/.cabal/bin/`. If you don't want to install profiling +and shared versions of the libraries, use + + $ EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh + +You then have the choice either to place `$HOME/.cabal/bin` on your +`$PATH` or move the `cabal` program to somewhere on your `$PATH`. Next, +you can get the latest list of packages by running: + + $ cabal update + +This will also create a default configuration file, if it does not +already exist, at `$HOME/.cabal/config`. + +By default, `cabal` will install programs to `$HOME/.cabal/bin`. If you +do not want to add this directory to your `$PATH`, you can change +the setting in the config file; for example, you could use the +following: + + symlink-bindir: $HOME/bin + + +Quick start on Windows systems +------------------------------ + +For Windows users, a precompiled program ([cabal.exe]) is provided. +Download and put it somewhere on your `%PATH%` (for example, +`C:\Program Files\Haskell\bin`.) + +Next, you can get the latest list of packages by running: + + $ cabal update + +This will also create a default configuration file (if it does not +already exist) at +`C:\Documents and Settings\%USERNAME%\Application Data\cabal\config`. + +[cabal.exe]: http://www.haskell.org/cabal/release/cabal-install-latest/ + +Using `cabal` +============= + +There are two sets of commands: commands for working with a local +project build tree and those for working with packages distributed +from [Hackage]. + +For the list of the full set of commands and flags for each command, +run: + + $ cabal help + + +Commands for developers for local build trees +--------------------------------------------- + +The commands for local project build trees are almost the same as the +`runghc Setup` command-line interface you may already be familiar with. +In particular, it has the following commands: + + * `cabal configure` + * `cabal build` + * `cabal haddock` + * `cabal clean` + * `cabal sdist` + +The `install` command is somewhat different; it is an all-in-one +operation. If you run `cabal install` in your build tree, it will +configure, build, and install. It takes all the flags that `configure` +takes such as `--global` and `--prefix`. + +In addition, `cabal` will download and install any dependencies that are +not already installed. It can also rebuild packages to ensure a +consistent set of dependencies. + + +Commands for released Hackage packages +-------------------------------------- + + $ cabal update + +This command gets the latest list of packages from the [Hackage] server. +On occasion, this command must be run manually--for instance, if you +want to install a newly released package. + + $ cabal install xmonad + +This command installs one or more named packages, and all their +dependencies, from Hackage. By default, it installs the latest available +version; however, you may specify exact versions or version ranges. For +example, `cabal install alex-2.2` or `cabal install parsec < 3`. + + $ cabal list xml + +This does a search of the installed and available packages. It does a +case-insensitive substring match on the package name. + + +[Hackage]: http://hackage.haskell.org +[bootstrap.sh]: bootstrap.sh diff --git a/bash-completion/cabal b/bash-completion/cabal --- a/bash-completion/cabal +++ b/bash-completion/cabal @@ -3,6 +3,62 @@ # "Duncan Coutts" # +# List cabal targets by type, pass: +# - test-suite for test suites +# - benchmark for benchmarks +# - executable for executables +# - executable|test-suite|benchmark for the three +_cabal_list() +{ + cat *.cabal | + grep -Ei "^[[:space:]]*($1)[[:space:]]" | + sed -e "s/.* \([^ ]*\).*/\1/" +} + +# List possible targets depending on the command supplied as parameter. The +# ideal option would be to implement this via --list-options on cabal directly. +# This is a temporary workaround. +_cabal_targets() +{ + # If command ($*) contains build, repl, test or bench completes with + # targets of according type. + [ -f *.cabal ] || return 0 + local comp + for comp in $*; do + [ $comp == build ] && _cabal_list "executable|test-suite|benchmark" && break + [ $comp == repl ] && _cabal_list "executable|test-suite|benchmark" && break + [ $comp == run ] && _cabal_list "executable" && break + [ $comp == test ] && _cabal_list "test-suite" && break + [ $comp == bench ] && _cabal_list "benchmark" && break + done +} + +# List possible subcommands of a cabal subcommand. +# +# In example "sandbox" is a cabal subcommand that itself has subcommands. Since +# "cabal --list-options" doesn't work in such cases we have to get the list +# using other means. +_cabal_subcommands() +{ + local word + for word in "$@"; do + case "$word" in + sandbox) + # Get list of "cabal sandbox" subcommands from its help message. + # + # Following command short-circuits if it reaches flags section. + # This is to prevent any problems that might arise from unfortunate + # word combinations in flag descriptions. Usage section is parsed + # using simple regexp and "sandbox" subcommand is printed for each + # successful substitution. + "$1" help sandbox | + sed -rn '/Flags/q;s/^.* sandbox *([^ ]*).*/\1/;t p;b;: p;p' + break # Terminate for loop. + ;; + esac + done +} + _cabal() { # get the word currently being completed @@ -18,7 +74,7 @@ cmd[${COMP_CWORD}]="--list-options" # the resulting completions should be put into this array - COMPREPLY=( $( compgen -W "$( ${cmd[@]} )" -- $cur ) ) + COMPREPLY=( $( compgen -W "$( ${cmd[@]} ) $( _cabal_targets ${cmd[@]} ) $( _cabal_subcommands ${COMP_WORDS[@]} )" -- $cur ) ) } complete -F _cabal -o default cabal diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -6,9 +6,13 @@ # HTTP packages. It then installs cabal-install itself. # It expects to be run inside the cabal-install directory. -# install settings, you can override these by setting environment vars +# Install settings, you can override these by setting environment vars. E.g. if +# you don't want profiling and dynamic versions of libraries to be installed in +# addition to vanilla, run 'EXTRA_CONFIGURE_OPTS="" ./bootstrap.sh' + #VERBOSE -#EXTRA_CONFIGURE_OPTS +DEFAULT_CONFIGURE_OPTS="--enable-library-profiling --enable-shared" +EXTRA_CONFIGURE_OPTS=${EXTRA_CONFIGURE_OPTS-$DEFAULT_CONFIGURE_OPTS} #EXTRA_BUILD_OPTS #EXTRA_INSTALL_OPTS @@ -23,8 +27,28 @@ CURL="${CURL:-curl}" FETCH="${FETCH:-fetch}" TAR="${TAR:-tar}" -GZIP="${GZIP:-gzip}" -SCOPE_OF_INSTALLATION="--user" +GZIP_PROGRAM="${GZIP_PROGRAM:-gzip}" + +# The variable SCOPE_OF_INSTALLATION can be set on the command line to +# use/install the libaries needed to build cabal-install to a custom package +# database instead of the user or global package database. +# +# Example: +# +# $ ghc-pkg init /my/package/database +# $ SCOPE_OF_INSTALLATION='--package-db=/my/package/database' ./bootstrap.sh +# +# You can also combine SCOPE_OF_INSTALLATION with PREFIX: +# +# $ ghc-pkg init /my/prefix/packages.conf.d +# $ SCOPE_OF_INSTALLATION='--package-db=/my/prefix/packages.conf.d' \ +# PREFIX=/my/prefix ./bootstrap.sh +# +# If you use the --global,--user or --sandbox arguments, this will +# override the SCOPE_OF_INSTALLATION setting and not use the package +# database you pass in the SCOPE_OF_INSTALLATION variable. + +SCOPE_OF_INSTALLATION="${SCOPE_OF_INSTALLATION:---user}" DEFAULT_PREFIX="${HOME}/.cabal" # Try to respect $TMPDIR but override if needed - see #1710. @@ -83,31 +107,67 @@ die "Version mismatch between ${GHC} and ${GHC_PKG}. If you set the GHC variable then set GHC_PKG too." -for arg in "$@" -do - case "${arg}" in +while [ "$#" -gt 0 ]; do + case "${1}" in "--user") - SCOPE_OF_INSTALLATION=${arg} + SCOPE_OF_INSTALLATION="${1}" shift;; "--global") - SCOPE_OF_INSTALLATION=${arg} + SCOPE_OF_INSTALLATION="${1}" DEFAULT_PREFIX="/usr/local" shift;; + "--sandbox") + shift + # check if there is another argument which doesn't start with -- + if [ "$#" -le 0 ] || [ ! -z $(echo "${1}" | grep "^--") ] + then + SANDBOX=".cabal-sandbox" + else + SANDBOX="${1}" + shift + fi;; "--no-doc") NO_DOCUMENTATION=1 shift;; *) - echo "Unknown argument or option, quitting: ${arg}" + echo "Unknown argument or option, quitting: ${1}" echo "usage: bootstrap.sh [OPTION]" echo echo "options:" - echo " --user Install for the local user (default)" - echo " --global Install systemwide (must be run as root)" - echo " --no-doc Do not generate documentation for installed packages" + echo " --user Install for the local user (default)" + echo " --global Install systemwide (must be run as root)" + echo " --no-doc Do not generate documentation for installed "\ + "packages" + echo " --sandbox Install to a sandbox in the default location"\ + "(.cabal-sandbox)" + echo " --sandbox path Install to a sandbox located at path" exit;; esac done +abspath () { case "$1" in /*)printf "%s\n" "$1";; *)printf "%s\n" "$PWD/$1";; + esac; } + +if [ ! -z "$SANDBOX" ] +then # set up variables for sandbox bootstrap + # Make the sandbox path absolute since it will be used from + # different working directories when the dependency packages are + # installed. + SANDBOX=$(abspath "$SANDBOX") + # Get the name of the package database which cabal sandbox would use. + GHC_ARCH=$(ghc --info | + sed -n 's/.*"Target platform".*"\([^-]\+\)-[^-]\+-\([^"]\+\)".*/\1-\2/p') + PACKAGEDB="$SANDBOX/${GHC_ARCH}-ghc-${GHC_VER}-packages.conf.d" + # Assume that if the directory is already there, it is already a + # package database. We will get an error immediately below if it + # isn't. Uses -r to try to be compatible with Solaris, and allow + # symlinks as well as a normal dir/file. + [ ! -r "$PACKAGEDB" ] && ghc-pkg init "$PACKAGEDB" + PREFIX="$SANDBOX" + SCOPE_OF_INSTALLATION="--package-db=$PACKAGEDB" + echo Bootstrapping in sandbox at \'$SANDBOX\'. +fi + # Check for haddock unless no documentation should be generated. if [ ! ${NO_DOCUMENTATION} ] then @@ -118,32 +178,38 @@ # Versions of the packages to install. # The version regex says what existing installed versions are ok. -PARSEC_VER="3.1.5"; PARSEC_VER_REGEXP="[23]\." - # == 2.* || == 3.* -DEEPSEQ_VER="1.3.0.2"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." +PARSEC_VER="3.1.7"; PARSEC_VER_REGEXP="[3]\.[01]\." + # >= 3.0 && < 3.2 +DEEPSEQ_VER="1.4.0.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2 -TEXT_VER="1.1.0.1"; TEXT_VER_REGEXP="((1\.[01]\.)|(0\.([2-9]|(1[0-1]))\.))" - # >= 0.2 && < 1.2 -NETWORK_VER="2.4.2.3"; NETWORK_VER_REGEXP="2\.[0-5]\." - # >= 2.0 && < 2.6 -CABAL_VER="1.20.0.4"; CABAL_VER_REGEXP="1\.2[01]\." - # >= 1.20 && < 1.21 -TRANS_VER="0.3.0.0"; TRANS_VER_REGEXP="0\.[23]\." - # >= 0.2.* && < 0.4.* -MTL_VER="2.1.3.1"; MTL_VER_REGEXP="[2]\." - # == 2.* -HTTP_VER="4000.2.12"; HTTP_VER_REGEXP="4000\.2\.[5-9]" +BINARY_VER="0.7.2.3"; BINARY_VER_REGEXP="[0]\.[7]\." + # == 0.7.* +TEXT_VER="1.2.0.3"; TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))" + # >= 0.2 && < 1.3 +NETWORK_VER="2.6.0.2"; NETWORK_VER_REGEXP="2\.[0-6]\." + # >= 2.0 && < 2.7 +NETWORK_URI_VER="2.6.0.1"; NETWORK_URI_VER_REGEXP="2\.6\." + # >= 2.6 && < 2.7 +CABAL_VER="1.22.0.0"; CABAL_VER_REGEXP="1\.22" + # >= 1.22 && < 1.23 +TRANS_VER="0.4.2.0"; TRANS_VER_REGEXP="0\.[4]\." + # >= 0.2.* && < 0.5 +MTL_VER="2.2.1"; MTL_VER_REGEXP="[2]\." + # >= 2.0 && < 3 +HTTP_VER="4000.2.19"; HTTP_VER_REGEXP="4000\.2\.([5-9]|1[0-9]|2[0-9])" # >= 4000.2.5 < 4000.3 -ZLIB_VER="0.5.4.1"; ZLIB_VER_REGEXP="0\.[45]\." +ZLIB_VER="0.5.4.2"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || == 0.5.* -TIME_VER="1.4.2" TIME_VER_REGEXP="1\.[1234]\.?" - # >= 1.1 && < 1.5 -RANDOM_VER="1.0.1.1" RANDOM_VER_REGEXP="1\.0\." - # >= 1 && < 1.1 -STM_VER="2.4.3"; STM_VER_REGEXP="2\." +TIME_VER="1.5" TIME_VER_REGEXP="1\.[12345]\.?" + # >= 1.1 && < 1.6 +RANDOM_VER="1.1" RANDOM_VER_REGEXP="1\.[01]\.?" + # >= 1 && < 1.2 +STM_VER="2.4.4"; STM_VER_REGEXP="2\." # == 2.* -NETWORK_URI_VER="2.6.0.1" NETWORK_URI_VER_REGEXP="2\.[6-9]\." - # >= 2.6 +OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?" + # >=1.0.0.0 && <1.2 +OLD_LOCALE_VER="1.0.0.7"; OLD_LOCALE_VER_REGEXP="1\.0\.?" + # >=1.0.0.0 && <1.1 HACKAGE_URL="https://hackage.haskell.org/package" @@ -175,7 +241,12 @@ if need_pkg ${PKG} ${VER_MATCH} then - echo "${PKG}-${VER} will be downloaded and installed." + if [ -r "${PKG}-${VER}.tar.gz" ] + then + echo "${PKG}-${VER} will be installed from local tarball." + else + echo "${PKG}-${VER} will be downloaded and installed." + fi else echo "${PKG} is already installed and the version is ok." fi @@ -210,12 +281,13 @@ VER=$2 rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}" - ${GZIP} -d < "${PKG}-${VER}.tar.gz" | ${TAR} -x + ${GZIP_PROGRAM} -d < "${PKG}-${VER}.tar.gz" | ${TAR} -xf - [ -d "${PKG}-${VER}" ] || die "Failed to unpack ${PKG}-${VER}.tar.gz" } install_pkg () { PKG=$1 + VER=$2 [ -x Setup ] && ./Setup clean [ -f Setup ] && rm Setup @@ -245,7 +317,7 @@ fi fi - ./Setup install ${SCOPE_OF_INSTALLATION} ${EXTRA_INSTALL_OPTS} ${VERBOSE} || + ./Setup install ${EXTRA_INSTALL_OPTS} ${VERBOSE} || die "Installing the ${PKG} package failed." } @@ -257,8 +329,13 @@ if need_pkg ${PKG} ${VER_MATCH} then echo - echo "Downloading ${PKG}-${VER}..." - fetch_pkg ${PKG} ${VER} + if [ -r "${PKG}-${VER}.tar.gz" ] + then + echo "Using local tarball for ${PKG}-${VER}." + else + echo "Downloading ${PKG}-${VER}..." + fetch_pkg ${PKG} ${VER} + fi unpack_pkg ${PKG} ${VER} cd "${PKG}-${VER}" install_pkg ${PKG} ${VER} @@ -288,6 +365,7 @@ # Actually do something! info_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} +info_pkg "binary" ${BINARY_VER} ${BINARY_VER_REGEXP} info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} info_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} @@ -295,12 +373,15 @@ info_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} +info_pkg "old-locale" ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP} +info_pkg "old-time" ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP} info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} info_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} info_pkg "stm" ${STM_VER} ${STM_VER_REGEXP} do_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} +do_pkg "binary" ${BINARY_VER} ${BINARY_VER_REGEXP} do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} @@ -312,12 +393,20 @@ # We conditionally install network-uri, depending on the network version. do_network_uri_pkg +do_pkg "old-locale" ${OLD_LOCALE_VER} ${OLD_LOCALE_VER_REGEXP} +do_pkg "old-time" ${OLD_TIME_VER} ${OLD_TIME_VER_REGEXP} do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} do_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} do_pkg "stm" ${STM_VER} ${STM_VER_REGEXP} install_pkg "cabal-install" + +# Use the newly built cabal to turn the prefix/package database into a +# legit cabal sandbox. This works because 'cabal sandbox init' will +# reuse the already existing package database and other files if they +# are in the expected locations. +[ ! -z "$SANDBOX" ] && $SANDBOX/bin/cabal sandbox init --sandbox $SANDBOX echo echo "===========================================" diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,5 +1,5 @@ Name: cabal-install -Version: 1.20.2.0 +Version: 1.22.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -22,9 +22,13 @@ 2007-2012 Duncan Coutts Category: Distribution Build-type: Simple -Extra-Source-Files: README bash-completion/cabal bootstrap.sh -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 +Extra-Source-Files: + README.md bash-completion/cabal bootstrap.sh changelog + -- Generated with '../Cabal/misc/gen-extra-source-files.sh | sort' + tests/PackageTests/Freeze/my.cabal + source-repository head type: git location: https://github.com/haskell/cabal/ @@ -34,9 +38,9 @@ description: Use directory < 1.2 and old-time default: False -flag network-uri - description: Get Network.URI from the network-uri package - default: True +Flag network-uri + description: Get Network.URI from the network-uri package + default: True executable cabal main-is: Main.hs @@ -73,6 +77,7 @@ Distribution.Client.Dependency.Modular.Tree Distribution.Client.Dependency.Modular.Validate Distribution.Client.Dependency.Modular.Version + Distribution.Client.Exec Distribution.Client.Fetch Distribution.Client.FetchUtils Distribution.Client.Freeze @@ -124,16 +129,15 @@ array >= 0.1 && < 0.6, base >= 4.3 && < 5, bytestring >= 0.9 && < 1, - Cabal >= 1.20.0 && < 1.21, + Cabal >= 1.22 && < 1.23, containers >= 0.1 && < 0.6, filepath >= 1.0 && < 1.4, HTTP >= 4000.2.5 && < 4000.3, mtl >= 2.0 && < 3, - network >= 2.0 && < 2.7, pretty >= 1 && < 1.2, random >= 1 && < 1.2, stm >= 2.0 && < 3, - time >= 1.1 && < 1.5, + time >= 1.1 && < 1.6, zlib >= 0.5.3 && < 0.6 if flag(old-directory) @@ -143,10 +147,13 @@ build-depends: directory >= 1.2 && < 1.3, process >= 1.1.0.2 && < 1.3 + -- NOTE: you MUST include the network dependency even when network-uri + -- is pulled in, otherwise the constraint solver doesn't have enough + -- information if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else - build-depends: network-uri < 2.6, network < 2.6 + build-depends: network >= 2.0 && < 2.6 if os(windows) build-depends: Win32 >= 2 && < 3 @@ -161,8 +168,9 @@ ghc-options: -threaded c-sources: cbits/getnumcores.c - + default-language: Haskell2010 +-- Small, fast running tests. Test-Suite unit-tests type: exitcode-stdio-1.0 main-is: UnitTests.hs @@ -172,6 +180,7 @@ UnitTests.Distribution.Client.Targets UnitTests.Distribution.Client.Dependency.Modular.PSQ UnitTests.Distribution.Client.Sandbox + UnitTests.Distribution.Client.UserConfig build-depends: base, array, @@ -212,3 +221,42 @@ cc-options: -DCABAL_NO_THREADED else ghc-options: -threaded + default-language: Haskell2010 + +-- Large, system tests that build packages. +test-suite package-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: PackageTests.hs + other-modules: + PackageTests.Exec.Check + PackageTests.Freeze.Check + PackageTests.PackageTester + build-depends: + Cabal, + HUnit, + QuickCheck >= 2.1.0.1 && < 2.8, + base, + bytestring, + directory, + extensible-exceptions, + filepath, + process, + regex-posix, + test-framework, + test-framework-hunit, + test-framework-quickcheck2 >= 0.2.12 + + if os(windows) + build-depends: Win32 >= 2 && < 3 + cpp-options: -DWIN32 + else + build-depends: unix >= 2.0 && < 2.8 + + if arch(arm) + cc-options: -DCABAL_NO_THREADED + else + ghc-options: -threaded + + ghc-options: -Wall + default-language: Haskell2010 diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,177 @@ +-*-change-log-*- + +1.21.x (current development version) + * New command: user-config (#2159). + * Implement 'cabal repl --only' (#2016). + * Fix an issue when 'cabal repl' was doing unnecessary compilation + (#1715). + * Prompt the user to specify source directory in 'cabal init' + (#1989). + * Remove the self-upgrade check (#2090). + * Don't redownload already downloaded packages when bootstrapping + (#2133). + * Support sandboxes in 'bootstrap.sh' (#2137). + * Install profiling and shared libs by default in 'bootstrap.sh' + (#2009). + +1.20.0.3 Johan Tibell June 2014 + * Don't attempt to rename dist if it is already named correctly + * Treat all flags of a package as interdependent. + * Allow template-haskell to be upgradable again + +1.20.0.2 Johan Tibell May 2014 + * Increase max-backjumps to 2000. + * Fix solver bug which led to missed install plans. + * Fix streaming test output. + * Tweak solver heuristics to avoid reinstalls. + +1.20.0.1 Johan Tibell May 2014 + * Fix cabal repl search path bug on Windows + * Include OS and arch in cabal-install user agent + * Revert --constraint flag behavior in configure to 1.18 behavior + +1.20.0.0 Johan Tibell April 2014 + * Build only selected executables + * Add -j flag to build/test/bench/run + * Improve install log file + * Don't symlink executables when in a sandbox + * Add --package-db flag to 'list' and 'info' + * Make upload more efficient + * Add --require-sandbox option + * Add experimental Cabal file format command + * Add haddock section to config file + * Add --main-is flag to init + +0.14.0 Andres Loeh April 2012 + * Works with ghc-7.4 + * Completely new modular dependency solver (default in most cases) + * Some tweaks to old topdown dependency solver + * Install plans are now checked for reinstalls that break packages + * Flags --constraint and --preference work for nonexisting packages + * New constraint forms for source and installed packages + * New constraint form for package-specific use flags + * New constraint form for package-specific stanza flags + * Test suite dependencies are pulled in on demand + * No longer install packages on --enable-tests when tests fail + * New "cabal bench" command + * Various "cabal init" tweaks + +0.10.0 Duncan Coutts February 2011 + * New package targets: local dirs, local and remote tarballs + * Initial support for a "world" package target + * Partial fix for situation where user packages mask global ones + * Removed cabal upgrade, new --upgrade-dependencies flag + * New cabal install --only-dependencies flag + * New cabal fetch --no-dependencies and --dry-run flags + * Improved output for cabal info + * Simpler and faster bash command line completion + * Fix for broken proxies that decompress wrongly + * Fix for cabal unpack to preserve executable permissions + * Adjusted the output for the -v verbosity level in a few places + +0.8.2 Duncan Coutts March 2010 + * Fix for cabal update on Windows + * On windows switch to per-user installs (rather than global) + * Handle intra-package dependencies in dependency planning + * Minor tweaks to cabal init feature + * Fix various -Wall warnings + * Fix for cabal sdist --snapshot + +0.8.0 Duncan Coutts Dec 2009 + * Works with ghc-6.12 + * New "cabal init" command for making initial project .cabal file + * New feature to maintain an index of haddock documentation + +0.6.4 Duncan Coutts Nov 2009 + * Improve the algorithm for selecting the base package version + * Hackage errors now reported by "cabal upload [--check]" + * Improved format of messages from "cabal check" + * Config file can now be selected by an env var + * Updated tar reading/writing code + * Improve instructions in the README and bootstrap output + * Fix bootstrap.sh on Solaris 9 + * Fix bootstrap for systems where network uses parsec 3 + * Fix building with ghc-6.6 + +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 + * 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 + * New cabal info command to display detailed info on packages + * New cabal unpack command to download and untar a package + * HTTP-4000 package required, should fix bugs with http proxies + * Now works with authenticated proxies. + * On Windows can now override the proxy setting using an env var + * Fix compatability with config files generated by older versions + * Warn if the hackage package list is very old + * More helpful --help output, mention config file and examples + * Better documentation in ~/.cabal/config file + * Improved command line interface for logging and build reporting + * Minor improvements to some messages + +0.6.0 Duncan Coutts Oct 2008 + * Constraint solver can now cope with base 3 and base 4 + * Allow use of package version preferences from hackage index + * More detailed output from cabal install --dry-run -v + * Improved bootstrap.sh + +0.5.2 Duncan Coutts Aug 2008 + * Suport building haddock documentaion + * Self-reinstall now works on Windows + * Allow adding symlinks to excutables into a separate bindir + * New self-documenting config file + * New install --reinstall flag + * More helpful status messages in a couple places + * Upload failures now report full text error message from the server + * Support for local package repositories + * New build logging and reporting + * New command to upload build reports to (a compatible) server + * Allow tilde in hackage server URIs + * Internal code improvements + * Many other minor improvements and bug fixes + +0.5.1 Duncan Coutts June 2008 + * Restore minimal hugs support in dependency resolver + * Fix for disabled http proxies on Windows + * Revert to global installs on Windows by default + +0.5.0 Duncan Coutts June 2008 + * New package dependency resolver, solving diamond dep problem + * Integrate cabal-setup functionality + * Integrate cabal-upload functionality + * New cabal update and check commands + * Improved behavior for install and upgrade commands + * Full Windows support + * New command line handling + * Bash command line completion + * Allow case insensitive package names on command line + * New --dry-run flag for install, upgrade and fetch commands + * New --root-cmd flag to allow installing as root + * New --cabal-lib-version flag to select different Cabal lib versions + * Support for HTTP proxies + * Improved cabal list output + * Build other non-dependent packages even when some fail + * Report a summary of all build failures at the end + * Partial support for hugs + * Partial implementation of build reporting and logging + * More consistent logging and verbosity + * Significant internal code restructuring + +0.4 Duncan Coutts Oct 2007 + * Renamed executable from 'cabal-install' to 'cabal' + * Partial Windows compatability + * Do per-user installs by default + * cabal install now installs the package in the current directory + * Allow multiple remote servers + * Use zlib lib and internal tar code and rather than external tar + * Reorganised configuration files + * Significant code restructuring + * Cope with packages with conditional dependencies + +0.3 and older versions by Lemmih, Paolo Martini and others 2006-2007 + * Switch from smart-server, dumb-client model to the reverse + * New .tar.gz based index format + * New remote and local package archive format diff --git a/tests/PackageTests.hs b/tests/PackageTests.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests.hs @@ -0,0 +1,88 @@ +-- | Groups black-box tests of cabal-install and configures them to test +-- the correct binary. +-- +-- This file should do nothing but import tests from other modules and run +-- them with the path to the correct cabal-install binary. +module Main + where + +-- Modules from Cabal. +import Distribution.Simple.Program.Builtin (ghcPkgProgram) +import Distribution.Simple.Program.Db + (defaultProgramDb, requireProgram, setProgramSearchPath) +import Distribution.Simple.Program.Find + (ProgramSearchPathEntry(ProgramSearchPathDir), defaultProgramSearchPath) +import Distribution.Simple.Program.Types + ( Program(..), simpleProgram, programPath) +import Distribution.Simple.Utils ( findProgramVersion ) +import Distribution.Verbosity (normal) + +-- Third party modules. +import qualified Control.Exception.Extensible as E +import System.Directory + ( canonicalizePath, getCurrentDirectory, setCurrentDirectory + , removeFile, doesFileExist ) +import System.FilePath (()) +import Test.Framework (Test, defaultMain, testGroup) +import Control.Monad ( when ) + +-- Module containing common test code. + +import PackageTests.PackageTester ( TestsPaths(..) + , packageTestsDirectory + , packageTestsConfigFile ) + +-- Modules containing the tests. +import qualified PackageTests.Exec.Check +import qualified PackageTests.Freeze.Check +import qualified PackageTests.MultipleSource.Check + +-- List of tests to run. Each test will be called with the path to the +-- cabal binary to use. +tests :: PackageTests.PackageTester.TestsPaths -> [Test] +tests paths = + [ testGroup "Freeze" $ PackageTests.Freeze.Check.tests paths + , testGroup "Exec" $ PackageTests.Exec.Check.tests paths + , testGroup "MultipleSource" $ PackageTests.MultipleSource.Check.tests paths + ] + +cabalProgram :: Program +cabalProgram = (simpleProgram "cabal") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +main :: IO () +main = do + buildDir <- canonicalizePath "dist/build/cabal" + let programSearchPath = ProgramSearchPathDir buildDir : defaultProgramSearchPath + (cabal, _) <- requireProgram normal cabalProgram + (setProgramSearchPath programSearchPath defaultProgramDb) + (ghcPkg, _) <- requireProgram normal ghcPkgProgram defaultProgramDb + canonicalConfigPath <- canonicalizePath $ "tests" packageTestsDirectory + + let testsPaths = TestsPaths { + cabalPath = programPath cabal, + ghcPkgPath = programPath ghcPkg, + configPath = canonicalConfigPath packageTestsConfigFile + } + + putStrLn $ "Using cabal: " ++ cabalPath testsPaths + putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath testsPaths + + cwd <- getCurrentDirectory + let confFile = packageTestsDirectory "cabal-config" + removeConf = do + b <- doesFileExist confFile + when b $ removeFile confFile + let runTests = do + setCurrentDirectory "tests" + removeConf -- assert that there is no existing config file + -- (we want deterministic testing with the default + -- config values) + defaultMain $ tests testsPaths + runTests `E.finally` do + -- remove the default config file that got created by the tests + removeConf + -- Change back to the old working directory so that the tests can be + -- repeatedly run in `cabal repl` via `:main`. + setCurrentDirectory cwd diff --git a/tests/PackageTests/Exec/Check.hs b/tests/PackageTests/Exec/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Exec/Check.hs @@ -0,0 +1,143 @@ +module PackageTests.Exec.Check + ( tests + ) where + + +import PackageTests.PackageTester + +import Test.Framework as TF (Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assertBool) + +import Control.Applicative ((<$>)) +import Control.Monad (when) +import Data.List (intercalate, isInfixOf) +import System.FilePath (()) +import System.Directory (getDirectoryContents) + +dir :: FilePath +dir = packageTestsDirectory "Exec" + +tests :: TestsPaths -> [TF.Test] +tests paths = + [ testCase "exits with failure if given no argument" $ do + result <- cabal_exec paths dir [] + assertExecFailed result + + , testCase "prints error message if given no argument" $ do + result <- cabal_exec paths dir [] + assertExecFailed result + let output = outputText result + expected = "specify an executable to run" + errMsg = "should have requested an executable be specified\n" ++ + output + assertBool errMsg $ + expected `isInfixOf` (intercalate " " . lines $ output) + + , testCase "runs the given command" $ do + result <- cabal_exec paths dir ["echo", "this", "string"] + assertExecSucceeded result + let output = outputText result + expected = "this string" + errMsg = "should have ran the given command\n" ++ output + assertBool errMsg $ + expected `isInfixOf` (intercalate " " . lines $ output) + + , testCase "can run executables installed in the sandbox" $ do + -- Test that an executable installed into the sandbox can be found. + -- We do this by removing any existing sandbox. Checking that the + -- executable cannot be found. Creating a new sandbox. Installing + -- the executable and checking it can be run. + + cleanPreviousBuilds paths + assertMyExecutableNotFound paths + assertPackageInstall paths + + result <- cabal_exec paths dir ["my-executable"] + assertExecSucceeded result + let output = outputText result + expected = "This is my-executable" + errMsg = "should have found a my-executable\n" ++ output + assertBool errMsg $ + expected `isInfixOf` (intercalate " " . lines $ output) + + , testCase "adds the sandbox bin directory to the PATH" $ do + cleanPreviousBuilds paths + assertMyExecutableNotFound paths + assertPackageInstall paths + + result <- cabal_exec paths dir ["bash", "--", "-c", "my-executable"] + assertExecSucceeded result + let output = outputText result + expected = "This is my-executable" + errMsg = "should have found a my-executable\n" ++ output + assertBool errMsg $ + expected `isInfixOf` (intercalate " " . lines $ output) + + , testCase "configures GHC to use the sandbox" $ do + let libNameAndVersion = "my-0.1" + + cleanPreviousBuilds paths + assertPackageInstall paths + + assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion + + result <- cabal_exec paths dir ["ghc-pkg", "list"] + assertExecSucceeded result + let output = outputText result + errMsg = "my library should have been found" + assertBool errMsg $ + libNameAndVersion `isInfixOf` (intercalate " " . lines $ output) + + + -- , testCase "can find executables built from the package" $ do + + , testCase "configures cabal to use the sandbox" $ do + let libNameAndVersion = "my-0.1" + + cleanPreviousBuilds paths + assertPackageInstall paths + + assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion + + result <- cabal_exec paths dir ["bash", "--", "-c", "cd subdir ; cabal sandbox hc-pkg list"] + assertExecSucceeded result + let output = outputText result + errMsg = "my library should have been found" + assertBool errMsg $ + libNameAndVersion `isInfixOf` (intercalate " " . lines $ output) + ] + +cleanPreviousBuilds :: TestsPaths -> IO () +cleanPreviousBuilds paths = do + sandboxExists <- not . null . filter (== "cabal.sandbox.config") <$> + getDirectoryContents dir + assertCleanSucceeded =<< cabal_clean paths dir [] + when sandboxExists $ do + assertSandboxSucceeded =<< cabal_sandbox paths dir ["delete"] + + +assertPackageInstall :: TestsPaths -> IO () +assertPackageInstall paths = do + assertSandboxSucceeded =<< cabal_sandbox paths dir ["init"] + assertInstallSucceeded =<< cabal_install paths dir [] + + +assertMyExecutableNotFound :: TestsPaths -> IO () +assertMyExecutableNotFound paths = do + result <- cabal_exec paths dir ["my-executable"] + assertExecFailed result + let output = outputText result + expected = "cabal: The program 'my-executable' is required but it " ++ + "could not be found" + errMsg = "should not have found a my-executable\n" ++ output + assertBool errMsg $ + expected `isInfixOf` (intercalate " " . lines $ output) + + + +assertMyLibIsNotAvailableOutsideofSandbox :: TestsPaths -> String -> IO () +assertMyLibIsNotAvailableOutsideofSandbox paths libNameAndVersion = do + (_, _, output) <- run (Just $ dir) (ghcPkgPath paths) ["list"] + assertBool "my library should not have been found" $ not $ + libNameAndVersion `isInfixOf` (intercalate " " . lines $ output) diff --git a/tests/PackageTests/Freeze/Check.hs b/tests/PackageTests/Freeze/Check.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Freeze/Check.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module PackageTests.Freeze.Check + ( tests + ) where + +import PackageTests.PackageTester + +import Test.Framework as TF (Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assertBool) + +import qualified Control.Exception.Extensible as E +import Data.List (intercalate, isInfixOf) +import System.Directory (doesFileExist, removeFile) +import System.FilePath (()) +import System.IO.Error (isDoesNotExistError) + +dir :: FilePath +dir = packageTestsDirectory "Freeze" + +tests :: TestsPaths -> [TF.Test] +tests paths = + [ testCase "runs without error" $ do + removeCabalConfig + result <- cabal_freeze paths dir [] + assertFreezeSucceeded result + + , testCase "freezes direct dependencies" $ do + removeCabalConfig + result <- cabal_freeze paths dir [] + assertFreezeSucceeded result + c <- readCabalConfig + assertBool ("should have frozen base\n" ++ c) $ + " base ==" `isInfixOf` (intercalate " " $ lines $ c) + + , testCase "freezes transitory dependencies" $ do + removeCabalConfig + result <- cabal_freeze paths dir [] + assertFreezeSucceeded result + c <- readCabalConfig + assertBool ("should have frozen ghc-prim\n" ++ c) $ + " ghc-prim ==" `isInfixOf` (intercalate " " $ lines $ c) + + , testCase "does not freeze packages which are not dependend upon" $ do + -- XXX Test this against a package installed in the sandbox but + -- not depended upon. + removeCabalConfig + result <- cabal_freeze paths dir [] + assertFreezeSucceeded result + c <- readCabalConfig + assertBool ("should not have frozen exceptions\n" ++ c) $ not $ + " exceptions ==" `isInfixOf` (intercalate " " $ lines $ c) + + , testCase "does not include a constraint for the package being frozen" $ do + removeCabalConfig + result <- cabal_freeze paths dir [] + assertFreezeSucceeded result + c <- readCabalConfig + assertBool ("should not have frozen self\n" ++ c) $ not $ + " my ==" `isInfixOf` (intercalate " " $ lines $ c) + + , testCase "--dry-run does not modify the cabal.config file" $ do + removeCabalConfig + result <- cabal_freeze paths dir ["--dry-run"] + assertFreezeSucceeded result + c <- doesFileExist $ dir "cabal.config" + assertBool "cabal.config file should not have been created" (not c) + + , testCase "--enable-tests freezes test dependencies" $ do + removeCabalConfig + result <- cabal_freeze paths dir ["--enable-tests"] + assertFreezeSucceeded result + c <- readCabalConfig + assertBool ("should have frozen test-framework\n" ++ c) $ + " test-framework ==" `isInfixOf` (intercalate " " $ lines $ c) + + , testCase "--disable-tests does not freeze test dependencies" $ do + removeCabalConfig + result <- cabal_freeze paths dir ["--disable-tests"] + assertFreezeSucceeded result + c <- readCabalConfig + assertBool ("should not have frozen test-framework\n" ++ c) $ not $ + " test-framework ==" `isInfixOf` (intercalate " " $ lines $ c) + + , testCase "--enable-benchmarks freezes benchmark dependencies" $ do + removeCabalConfig + result <- cabal_freeze paths dir ["--disable-benchmarks"] + assertFreezeSucceeded result + c <- readCabalConfig + assertBool ("should not have frozen criterion\n" ++ c) $ not $ + " criterion ==" `isInfixOf` (intercalate " " $ lines $ c) + + , testCase "--disable-benchmarks does not freeze benchmark dependencies" $ do + removeCabalConfig + result <- cabal_freeze paths dir ["--disable-benchmarks"] + assertFreezeSucceeded result + c <- readCabalConfig + assertBool ("should not have frozen criterion\n" ++ c) $ not $ + " criterion ==" `isInfixOf` (intercalate " " $ lines $ c) + ] + +removeCabalConfig :: IO () +removeCabalConfig = do + removeFile (dir "cabal.config") + `E.catch` \ (e :: IOError) -> + if isDoesNotExistError e + then return () + else E.throw e + + +readCabalConfig :: IO String +readCabalConfig = do + readFile $ dir "cabal.config" diff --git a/tests/PackageTests/Freeze/my.cabal b/tests/PackageTests/Freeze/my.cabal new file mode 100644 --- /dev/null +++ b/tests/PackageTests/Freeze/my.cabal @@ -0,0 +1,21 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.20.0 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +test-suite test-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test-Foo.hs + build-depends: base, my, test-framework + +benchmark bench-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: benchmark-Foo.hs + build-depends: base, my, criterion diff --git a/tests/PackageTests/PackageTester.hs b/tests/PackageTests/PackageTester.hs new file mode 100644 --- /dev/null +++ b/tests/PackageTests/PackageTester.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- TODO This module was originally based on the PackageTests.PackageTester +-- module in Cabal, however it has a few differences. I suspect that as +-- this module ages the two modules will diverge further. As such, I have +-- not attempted to merge them into a single module nor to extract a common +-- module from them. Refactor this module and/or Cabal's +-- PackageTests.PackageTester to remove commonality. +-- 2014-05-15 Ben Armston + +-- | Routines for black-box testing cabal-install. +-- +-- Instead of driving the tests by making library calls into +-- Distribution.Simple.* or Distribution.Client.* this module only every +-- executes the `cabal-install` binary. +-- +-- You can set the following VERBOSE environment variable to control +-- the verbosity of the output generated by this module. +module PackageTests.PackageTester + ( TestsPaths(..) + , Result(..) + + , packageTestsDirectory + , packageTestsConfigFile + + -- * Running cabal commands + , cabal_clean + , cabal_exec + , cabal_freeze + , cabal_install + , cabal_sandbox + , run + + -- * Test helpers + , assertCleanSucceeded + , assertExecFailed + , assertExecSucceeded + , assertFreezeSucceeded + , assertInstallSucceeded + , assertSandboxSucceeded + ) where + +import qualified Control.Exception.Extensible as E +import Control.Monad (when, unless) +import Data.Maybe (fromMaybe) +import System.Directory (canonicalizePath, doesFileExist) +import System.Environment (getEnv) +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath ( (<.>) ) +import System.IO (hClose, hGetChar, hIsEOF) +import System.IO.Error (isDoesNotExistError) +import System.Process (runProcess, waitForProcess) +import Test.HUnit (Assertion, assertFailure) + +import Distribution.Simple.BuildPaths (exeExtension) +import Distribution.Simple.Utils (printRawCommandAndArgs) +import Distribution.Compat.CreatePipe (createPipe) +import Distribution.ReadE (readEOrFail) +import Distribution.Verbosity (Verbosity, flagToVerbosity, normal) + +data Success = Failure + -- | ConfigureSuccess + -- | BuildSuccess + -- | TestSuccess + -- | BenchSuccess + | CleanSuccess + | ExecSuccess + | FreezeSuccess + | InstallSuccess + | SandboxSuccess + deriving (Eq, Show) + +data TestsPaths = TestsPaths + { cabalPath :: FilePath -- ^ absolute path to cabal executable. + , ghcPkgPath :: FilePath -- ^ absolute path to ghc-pkg executable. + , configPath :: FilePath -- ^ absolute path of the default config file + -- to use for tests (tests are free to use + -- a different one). + } + +data Result = Result + { successful :: Bool + , success :: Success + , outputText :: String + } deriving Show + +nullResult :: Result +nullResult = Result True Failure "" + +------------------------------------------------------------------------ +-- * Config + +packageTestsDirectory :: FilePath +packageTestsDirectory = "PackageTests" + +packageTestsConfigFile :: FilePath +packageTestsConfigFile = "cabal-config" + +------------------------------------------------------------------------ +-- * Running cabal commands + +recordRun :: (String, ExitCode, String) -> Success -> Result -> Result +recordRun (cmd, exitCode, exeOutput) thisSucc res = + res { successful = successful res && exitCode == ExitSuccess + , success = if exitCode == ExitSuccess then thisSucc + else success res + , outputText = + (if null $ outputText res then "" else outputText res ++ "\n") ++ + cmd ++ "\n" ++ exeOutput + } + +-- | Run the clean command and return its result. +cabal_clean :: TestsPaths -> FilePath -> [String] -> IO Result +cabal_clean paths dir args = do + res <- cabal paths dir (["clean"] ++ args) + return $ recordRun res CleanSuccess nullResult + +-- | Run the exec command and return its result. +cabal_exec :: TestsPaths -> FilePath -> [String] -> IO Result +cabal_exec paths dir args = do + res <- cabal paths dir (["exec"] ++ args) + return $ recordRun res ExecSuccess nullResult + +-- | Run the freeze command and return its result. +cabal_freeze :: TestsPaths -> FilePath -> [String] -> IO Result +cabal_freeze paths dir args = do + res <- cabal paths dir (["freeze"] ++ args) + return $ recordRun res FreezeSuccess nullResult + +-- | Run the install command and return its result. +cabal_install :: TestsPaths -> FilePath -> [String] -> IO Result +cabal_install paths dir args = do + res <- cabal paths dir (["install"] ++ args) + return $ recordRun res InstallSuccess nullResult + +-- | Run the sandbox command and return its result. +cabal_sandbox :: TestsPaths -> FilePath -> [String] -> IO Result +cabal_sandbox paths dir args = do + res <- cabal paths dir (["sandbox"] ++ args) + return $ recordRun res SandboxSuccess nullResult + +-- | Returns the command that was issued, the return code, and the output text. +cabal :: TestsPaths -> FilePath -> [String] -> IO (String, ExitCode, String) +cabal paths dir cabalArgs = do + run (Just dir) (cabalPath paths) args + where + args = configFileArg : cabalArgs + configFileArg = "--config-file=" ++ configPath paths + +-- | Returns the command that was issued, the return code, and the output text +run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String) +run cwd path args = do + verbosity <- getVerbosity + -- path is relative to the current directory; canonicalizePath makes it + -- absolute, so that runProcess will find it even when changing directory. + path' <- do pathExists <- doesFileExist path + canonicalizePath (if pathExists then path else path <.> exeExtension) + printRawCommandAndArgs verbosity path' args + (readh, writeh) <- createPipe + pid <- runProcess path' args cwd Nothing Nothing (Just writeh) (Just writeh) + + -- fork off a thread to start consuming the output + out <- suckH [] readh + hClose readh + + -- wait for the program to terminate + exitcode <- waitForProcess pid + let fullCmd = unwords (path' : args) + return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out) + where + suckH output h = do + eof <- hIsEOF h + if eof + then return (reverse output) + else do + c <- hGetChar h + suckH (c:output) h + +------------------------------------------------------------------------ +-- * Test helpers + +assertCleanSucceeded :: Result -> Assertion +assertCleanSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'cabal clean\' should succeed\n" ++ + " output: " ++ outputText result + +assertExecSucceeded :: Result -> Assertion +assertExecSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'cabal exec\' should succeed\n" ++ + " output: " ++ outputText result + +assertExecFailed :: Result -> Assertion +assertExecFailed result = when (successful result) $ + assertFailure $ + "expected: \'cabal exec\' should fail\n" ++ + " output: " ++ outputText result + +assertFreezeSucceeded :: Result -> Assertion +assertFreezeSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'cabal freeze\' should succeed\n" ++ + " output: " ++ outputText result + +assertInstallSucceeded :: Result -> Assertion +assertInstallSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'cabal install\' should succeed\n" ++ + " output: " ++ outputText result + +assertSandboxSucceeded :: Result -> Assertion +assertSandboxSucceeded result = unless (successful result) $ + assertFailure $ + "expected: \'cabal sandbox\' should succeed\n" ++ + " output: " ++ outputText result + +------------------------------------------------------------------------ +-- Verbosity + +lookupEnv :: String -> IO (Maybe String) +lookupEnv name = + (fmap Just $ getEnv name) + `E.catch` \ (e :: IOError) -> + if isDoesNotExistError e + then return Nothing + else E.throw e + +-- TODO: Convert to a "-v" flag instead. +getVerbosity :: IO Verbosity +getVerbosity = do + maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE" diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs --- a/tests/UnitTests.hs +++ b/tests/UnitTests.hs @@ -4,12 +4,15 @@ import Test.Framework import qualified UnitTests.Distribution.Client.Sandbox +import qualified UnitTests.Distribution.Client.UserConfig import qualified UnitTests.Distribution.Client.Targets import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ tests :: [Test] tests = [ - testGroup "Distribution.Client.Sandbox" + testGroup "UnitTests.Distribution.Client.UserConfig" + UnitTests.Distribution.Client.UserConfig.tests + ,testGroup "Distribution.Client.Sandbox" UnitTests.Distribution.Client.Sandbox.tests ,testGroup "Distribution.Client.Targets" UnitTests.Distribution.Client.Targets.tests diff --git a/tests/UnitTests/Distribution/Client/UserConfig.hs b/tests/UnitTests/Distribution/Client/UserConfig.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Client/UserConfig.hs @@ -0,0 +1,101 @@ +module UnitTests.Distribution.Client.UserConfig + ( tests + ) where + +import Control.Exception (bracket) +import Data.List (sort, nub) +import Data.Monoid +import System.Directory (getCurrentDirectory, removeDirectoryRecursive, createDirectoryIfMissing) +import System.FilePath (takeDirectory) + +import Test.Framework as TF (Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertBool) + +import Distribution.Client.Compat.Environment (lookupEnv, setEnv) +import Distribution.Client.Config +import Distribution.Utils.NubList (fromNubList) +import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..)) +import Distribution.Simple.Setup (ConfigFlags (..), fromFlag) +import Distribution.Verbosity (silent) + +tests :: [TF.Test] +tests = [ testCase "nullDiffOnCreate" nullDiffOnCreateTest + , testCase "canDetectDifference" canDetectDifference + , testCase "canUpdateConfig" canUpdateConfig + , testCase "doubleUpdateConfig" doubleUpdateConfig + ] + +nullDiffOnCreateTest :: Assertion +nullDiffOnCreateTest = bracketTest . const $ do + -- Create a new default config file in our test directory. + _ <- loadConfig silent mempty mempty + -- Now we read it in and compare it against the default. + diff <- userConfigDiff mempty + assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff + + +canDetectDifference :: Assertion +canDetectDifference = bracketTest . const $ do + -- Create a new default config file in our test directory. + _ <- loadConfig silent mempty mempty + cabalFile <- defaultConfigFile + appendFile cabalFile "verbose: 0\n" + diff <- userConfigDiff mempty + assertBool (unlines $ "Should detect a difference:" : diff) $ + diff == [ "- verbose: 1", "+ verbose: 0" ] + + +canUpdateConfig :: Assertion +canUpdateConfig = bracketTest . const $ do + cabalFile <- defaultConfigFile + createDirectoryIfMissing True $ takeDirectory cabalFile + -- Write a trivial cabal file. + writeFile cabalFile "tests: True\n" + -- Update the config file. + userConfigUpdate silent mempty + -- Load it again. + updated <- loadConfig silent mempty mempty + assertBool ("Field 'tests' should be True") $ + fromFlag (configTests $ savedConfigureFlags updated) + + +doubleUpdateConfig :: Assertion +doubleUpdateConfig = bracketTest . const $ do + -- Create a new default config file in our test directory. + _ <- loadConfig silent mempty mempty + -- Update it. + userConfigUpdate silent mempty + userConfigUpdate silent mempty + -- Load it again. + updated <- loadConfig silent mempty mempty + + assertBool ("Field 'remote-repo' doesn't contain duplicates") $ + listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated) + assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $ + listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated) + assertBool ("Field 'build-summary' doesn't contain duplicates") $ + listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated) + + +listUnique :: Ord a => [a] -> Bool +listUnique xs = + let sorted = sort xs + in nub sorted == xs + + +bracketTest :: ((FilePath, FilePath) -> IO ()) -> Assertion +bracketTest = + bracket testSetup testTearDown + where + testSetup :: IO (FilePath, FilePath) + testSetup = do + Just oldHome <- lookupEnv "HOME" + testdir <- fmap (++ "/test-user-config") getCurrentDirectory + setEnv "HOME" testdir + return (oldHome, testdir) + + testTearDown :: (FilePath, FilePath) -> IO () + testTearDown (oldHome, testdir) = do + setEnv "HOME" oldHome + removeDirectoryRecursive testdir