cabal-install 1.20.2.0 → 1.22.0.0
raw patch · 63 files changed
+3208/−1012 lines, 63 filesdep +extensible-exceptionsdep +regex-posixdep ~Cabaldep ~QuickCheckdep ~base
Dependencies added: extensible-exceptions, regex-posix
Dependency ranges changed: Cabal, QuickCheck, base, bytestring, directory, filepath, network, network-uri, process, test-framework-quickcheck2, time
Files
- Distribution/Client/BuildReports/Anonymous.hs +11/−10
- Distribution/Client/BuildReports/Storage.hs +42/−19
- Distribution/Client/BuildReports/Upload.hs +4/−0
- Distribution/Client/Compat/Environment.hs +0/−1
- Distribution/Client/Compat/Time.hs +20/−10
- Distribution/Client/Config.hs +124/−27
- Distribution/Client/Configure.hs +9/−7
- Distribution/Client/Dependency.hs +39/−14
- Distribution/Client/Dependency/Modular.hs +2/−2
- Distribution/Client/Dependency/Modular/ConfiguredConversion.hs +4/−4
- Distribution/Client/Dependency/Modular/Dependency.hs +7/−33
- Distribution/Client/Dependency/Modular/Flag.hs +3/−8
- Distribution/Client/Dependency/Modular/IndexConversion.hs +38/−31
- Distribution/Client/Dependency/Modular/Message.hs +10/−7
- Distribution/Client/Dependency/Modular/PSQ.hs +2/−11
- Distribution/Client/Dependency/Modular/Package.hs +2/−4
- Distribution/Client/Dependency/Modular/Preference.hs +6/−5
- Distribution/Client/Dependency/Modular/Tree.hs +3/−34
- Distribution/Client/Dependency/TopDown.hs +13/−12
- Distribution/Client/Dependency/Types.hs +34/−12
- Distribution/Client/Exec.hs +119/−0
- Distribution/Client/Fetch.hs +5/−5
- Distribution/Client/Freeze.hs +21/−9
- Distribution/Client/Haddock.hs +2/−2
- Distribution/Client/HttpUtils.hs +6/−6
- Distribution/Client/IndexUtils.hs +52/−33
- Distribution/Client/Init.hs +39/−19
- Distribution/Client/Init/Licenses.hs +18/−1
- Distribution/Client/Install.hs +191/−92
- Distribution/Client/InstallPlan.hs +116/−44
- Distribution/Client/InstallSymlink.hs +32/−21
- Distribution/Client/List.hs +50/−22
- Distribution/Client/PackageIndex.hs +2/−4
- Distribution/Client/Run.hs +33/−5
- Distribution/Client/Sandbox.hs +17/−9
- Distribution/Client/Sandbox/Index.hs +10/−5
- Distribution/Client/Sandbox/PackageEnvironment.hs +11/−10
- Distribution/Client/Sandbox/Timestamp.hs +22/−17
- Distribution/Client/Sandbox/Types.hs +1/−1
- Distribution/Client/Setup.hs +441/−85
- Distribution/Client/SetupWrapper.hs +107/−32
- Distribution/Client/Tar.hs +2/−3
- Distribution/Client/Targets.hs +8/−3
- Distribution/Client/Types.hs +44/−12
- Distribution/Client/Update.hs +2/−32
- Distribution/Client/Upload.hs +22/−5
- Distribution/Client/Utils.hs +52/−2
- Distribution/Client/Win32SelfUpgrade.hs +12/−7
- Distribution/Client/World.hs +3/−5
- Main.hs +115/−74
- README +0/−143
- README.md +155/−0
- bash-completion/cabal +57/−1
- bootstrap.sh +129/−40
- cabal-install.cabal +59/−11
- changelog +177/−0
- tests/PackageTests.hs +88/−0
- tests/PackageTests/Exec/Check.hs +143/−0
- tests/PackageTests/Freeze/Check.hs +114/−0
- tests/PackageTests/Freeze/my.cabal +21/−0
- tests/PackageTests/PackageTester.hs +232/−0
- tests/UnitTests.hs +4/−1
- tests/UnitTests/Distribution/Client/UserConfig.hs +101/−0
Distribution/Client/BuildReports/Anonymous.hs view
@@ -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)
Distribution/Client/BuildReports/Storage.hs view
@@ -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 ]
Distribution/Client/BuildReports/Upload.hs view
@@ -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
Distribution/Client/Compat/Environment.hs view
@@ -20,7 +20,6 @@ #ifdef mingw32_HOST_OS import GHC.Windows-import Foreign.Safe import Foreign.C import Control.Monad #else
Distribution/Client/Compat/Time.hs view
@@ -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
Distribution/Client/Config.hs view
@@ -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)
Distribution/Client/Configure.hs view
@@ -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
Distribution/Client/Dependency.hs view
@@ -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
Distribution/Client/Dependency/Modular.hs view
@@ -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)
Distribution/Client/Dependency/Modular/ConfiguredConversion.hs view
@@ -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
Distribution/Client/Dependency/Modular/Dependency.hs view
@@ -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 ...
Distribution/Client/Dependency/Modular/Flag.hs view
@@ -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
Distribution/Client/Dependency/Modular/IndexConversion.hs view
@@ -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
Distribution/Client/Dependency/Modular/Message.hs view
@@ -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]
Distribution/Client/Dependency/Modular/PSQ.hs view
@@ -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
Distribution/Client/Dependency/Modular/Package.hs view
@@ -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]
Distribution/Client/Dependency/Modular/Preference.hs view
@@ -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.
Distribution/Client/Dependency/Modular/Tree.hs view
@@ -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
Distribution/Client/Dependency/TopDown.hs view
@@ -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") ++ "' "
Distribution/Client/Dependency/Types.hs view
@@ -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
+ Distribution/Client/Exec.hs view
@@ -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
Distribution/Client/Fetch.hs view
@@ -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
Distribution/Client/Freeze.hs view
@@ -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
Distribution/Client/Haddock.hs view
@@ -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
Distribution/Client/HttpUtils.hs view
@@ -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
Distribution/Client/IndexUtils.hs view
@@ -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
Distribution/Client/Init.hs view
@@ -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.
Distribution/Client/Init/Licenses.hs view
@@ -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." ]
Distribution/Client/Install.hs view
@@ -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
Distribution/Client/InstallPlan.hs view
@@ -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
Distribution/Client/InstallSymlink.hs view
@@ -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@
Distribution/Client/List.hs view
@@ -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
Distribution/Client/PackageIndex.hs view
@@ -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
Distribution/Client/Run.hs view
@@ -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'
Distribution/Client/Sandbox.hs view
@@ -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
Distribution/Client/Sandbox/Index.hs view
@@ -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
Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -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 }
Distribution/Client/Sandbox/Timestamp.hs view
@@ -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
Distribution/Client/Sandbox/Types.hs view
@@ -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.
Distribution/Client/Setup.hs view
@@ -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]
Distribution/Client/SetupWrapper.hs view
@@ -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
Distribution/Client/Tar.hs view
@@ -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
Distribution/Client/Targets.hs view
@@ -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,
Distribution/Client/Types.hs view
@@ -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
Distribution/Client/Update.hs view
@@ -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"
Distribution/Client/Upload.hs view
@@ -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
Distribution/Client/Utils.hs view
@@ -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
Distribution/Client/Win32SelfUpgrade.hs view
@@ -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 ()
Distribution/Client/World.hs view
@@ -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
Main.hs view
@@ -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. --
− README
@@ -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.
+ README.md view
@@ -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
bash-completion/cabal view
@@ -3,6 +3,62 @@ # "Duncan Coutts" <dcoutts@gentoo.org> # +# 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
bootstrap.sh view
@@ -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 "==========================================="
cabal-install.cabal view
@@ -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 <duncan@community.haskell.org> 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
+ changelog view
@@ -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 <johan.tibell@gmail.com> 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 <johan.tibell@gmail.com> 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 <johan.tibell@gmail.com> 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 <johan.tibell@gmail.com> 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 <andres@well-typed.com> 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 <duncan@community.haskell.org> 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 <duncan@community.haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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
+ tests/PackageTests.hs view
@@ -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
+ tests/PackageTests/Exec/Check.hs view
@@ -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)
+ tests/PackageTests/Freeze/Check.hs view
@@ -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"
+ tests/PackageTests/Freeze/my.cabal view
@@ -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
+ tests/PackageTests/PackageTester.hs view
@@ -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"
tests/UnitTests.hs view
@@ -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
+ tests/UnitTests/Distribution/Client/UserConfig.hs view
@@ -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