cabal-install 1.18.2.0 → 1.20.0.0

raw patch · 53 files changed

+2956/−1310 lines, 53 filesdep −network-uridep ~Cabaldep ~HTTPdep ~base

Dependencies removed: network-uri

Dependency ranges changed: Cabal, HTTP, base, network, random, time

Files

Distribution/Client/BuildReports/Anonymous.hs +6/−6
Distribution/Client/BuildReports/Storage.hs +3/−2
Distribution/Client/Compat/Environment.hs +1/−1
Distribution/Client/Compat/ExecutablePath.hs +183/−0
Distribution/Client/Compat/Process.hs +48/−0
Distribution/Client/Config.hs +65/−192
Distribution/Client/Configure.hs +47/−19
Distribution/Client/Dependency.hs +105/−25
Distribution/Client/Dependency/Modular.hs +1/−1
Distribution/Client/Dependency/Modular/Builder.hs +4/−30
Distribution/Client/Dependency/Modular/Dependency.hs +2/−12
Distribution/Client/Dependency/Modular/Explore.hs +3/−3
Distribution/Client/Dependency/Modular/Flag.hs +3/−7
Distribution/Client/Dependency/Modular/IndexConversion.hs +18/−27
Distribution/Client/Dependency/Modular/PSQ.hs +1/−1
Distribution/Client/Dependency/Modular/Preference.hs +5/−6
Distribution/Client/Dependency/Modular/Solver.hs +8/−7
Distribution/Client/Dependency/Modular/Tree.hs +1/−6
Distribution/Client/Dependency/Modular/Validate.hs +1/−1
Distribution/Client/Dependency/Modular/Version.hs +0/−1
Distribution/Client/Dependency/Types.hs +25/−2
Distribution/Client/Fetch.hs +0/−3
Distribution/Client/Freeze.hs +215/−0
Distribution/Client/Get.hs +5/−3
Distribution/Client/Haddock.hs +12/−52
Distribution/Client/HttpUtils.hs +7/−7
Distribution/Client/IndexUtils.hs +7/−7
Distribution/Client/Init.hs +47/−17
Distribution/Client/Init/Heuristics.hs +70/−19
Distribution/Client/Init/Licenses.hs +552/−98
Distribution/Client/Init/Types.hs +4/−1
Distribution/Client/Install.hs +233/−121
Distribution/Client/InstallPlan.hs +40/−21
Distribution/Client/InstallSymlink.hs +12/−12
Distribution/Client/List.hs +31/−17
Distribution/Client/PackageIndex.hs +7/−4
Distribution/Client/ParseUtils.hs +9/−4
Distribution/Client/Sandbox.hs +69/−44
Distribution/Client/Sandbox/Index.hs +2/−2
Distribution/Client/Sandbox/PackageEnvironment.hs +117/−45
Distribution/Client/Sandbox/Timestamp.hs +2/−3
Distribution/Client/Setup.hs +300/−113
Distribution/Client/SetupWrapper.hs +163/−130
Distribution/Client/SrcDist.hs +1/−1
Distribution/Client/Tar.hs +15/−6
Distribution/Client/Targets.hs +3/−4
Distribution/Client/Types.hs +22/−0
Distribution/Client/Upload.hs +45/−23
Distribution/Client/Utils.hs +41/−5
Distribution/Client/Win32SelfUpgrade.hs +4/−4
Main.hs +245/−84
bootstrap.sh +133/−89
cabal-install.cabal +13/−22

Distribution/Client/BuildReports/Anonymous.hs view

@@ -146,17 +146,17 @@       Left  (BR.BuildFailed     _) -> BuildFailed       Left  (BR.TestsFailed     _) -> TestsFailed       Left  (BR.InstallFailed   _) -> InstallFailed-      Right (BR.BuildOk       _ _) -> InstallOk+      Right (BR.BuildOk       _ _ _) -> InstallOk     convertDocsOutcome = case result of       Left _                                -> NotTried-      Right (BR.BuildOk BR.DocsNotTried _)  -> NotTried-      Right (BR.BuildOk BR.DocsFailed _)    -> Failed-      Right (BR.BuildOk BR.DocsOk _)        -> Ok+      Right (BR.BuildOk BR.DocsNotTried _ _)  -> NotTried+      Right (BR.BuildOk BR.DocsFailed _ _)    -> Failed+      Right (BR.BuildOk BR.DocsOk _ _)        -> Ok     convertTestsOutcome = case result of       Left  (BR.TestsFailed _)              -> Failed       Left _                                -> NotTried-      Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried-      Right (BR.BuildOk _ BR.TestsOk)       -> Ok+      Right (BR.BuildOk _ BR.TestsNotTried _) -> NotTried+      Right (BR.BuildOk _ BR.TestsOk _)       -> Ok  cabalInstallID :: PackageIdentifier cabalInstallID =

Distribution/Client/BuildReports/Storage.hs view

@@ -117,9 +117,10 @@                 -> Maybe (BuildReport, Repo) fromPlanPackage (Platform arch os) comp planPackage = case planPackage of -  InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage {+  InstallPlan.Installed pkg@(ReadyPackage (SourcePackage {                           packageSource = RepoTarballPackage repo _ _ }) _ _ _) result-    -> Just $ (BuildReport.new os arch comp pkg (Right result), repo)+    -> Just $ (BuildReport.new os arch comp+               (readyPackageToConfiguredPackage pkg) (Right result), repo)    InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {                        packageSource = RepoTarballPackage repo _ _ }) _ _ _) result

Distribution/Client/Compat/Environment.hs view

@@ -54,7 +54,7 @@   | otherwise  = setEnv_ key value   where     -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We-    -- still strip it manually so that the null check above succeds if a value+    -- still strip it manually so that the null check above succeeds if a value     -- starts with NUL.     value = takeWhile (/= '\NUL') value_

+ Distribution/Client/Compat/ExecutablePath.hs view

@@ -0,0 +1,183 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}++-- Copied verbatim from base-4.6.0.0. We can't simply import+-- System.Environment.getExecutablePath because we need compatibility with older+-- GHCs.++module Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) where++-- The imports are purposely kept completely disjoint to prevent edits+-- to one OS implementation from breaking another.++#if defined(darwin_HOST_OS)+import Data.Word+import Foreign.C+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import System.Posix.Internals+#elif defined(linux_HOST_OS)+import Foreign.C+import Foreign.Marshal.Array+import System.Posix.Internals+#elif defined(mingw32_HOST_OS)+import Data.Word+import Foreign.C+import Foreign.Marshal.Array+import Foreign.Ptr+import System.Posix.Internals+#else+import Foreign.C+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import System.Posix.Internals+#endif++-- GHC 7.0.* compatibility. 'System.Posix.Internals' in base-4.3.* doesn't+-- provide 'peekFilePath' and 'peekFilePathLen'.+#if !MIN_VERSION_base(4,4,0)+#ifdef mingw32_HOST_OS++peekFilePath :: CWString -> IO FilePath+peekFilePath = peekCWString++#else++peekFilePath :: CString -> IO FilePath+peekFilePath = peekCString++peekFilePathLen :: CStringLen -> IO FilePath+peekFilePathLen = peekCStringLen++#endif+#endif++-- The exported function is defined outside any if-guard to make sure+-- every OS implements it with the same type.++-- | Returns the absolute pathname of the current executable.+--+-- Note that for scripts and interactive sessions, this is the path to+-- the interpreter (e.g. ghci.)+--+-- /Since: 4.6.0.0/+getExecutablePath :: IO FilePath++--------------------------------------------------------------------------------+-- Mac OS X++#if defined(darwin_HOST_OS)++type UInt32 = Word32++foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath"+    c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt++-- | Returns the path of the main executable. The path may be a+-- symbolic link and not the real file.+--+-- See dyld(3)+_NSGetExecutablePath :: IO FilePath+_NSGetExecutablePath =+    allocaBytes 1024 $ \ buf ->  -- PATH_MAX is 1024 on OS X+    alloca $ \ bufsize -> do+        poke bufsize 1024+        status <- c__NSGetExecutablePath buf bufsize+        if status == 0+            then peekFilePath buf+            else do reqBufsize <- fromIntegral `fmap` peek bufsize+                    allocaBytes reqBufsize $ \ newBuf -> do+                        status2 <- c__NSGetExecutablePath newBuf bufsize+                        if status2 == 0+                             then peekFilePath newBuf+                             else error "_NSGetExecutablePath: buffer too small"++foreign import ccall unsafe "stdlib.h realpath"+    c_realpath :: CString -> CString -> IO CString++-- | Resolves all symbolic links, extra \/ characters, and references+-- to \/.\/ and \/..\/. Returns an absolute pathname.+--+-- See realpath(3)+realpath :: FilePath -> IO FilePath+realpath path =+    withFilePath path $ \ fileName ->+    allocaBytes 1024 $ \ resolvedName -> do+        _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName+        peekFilePath resolvedName++getExecutablePath = _NSGetExecutablePath >>= realpath++--------------------------------------------------------------------------------+-- Linux++#elif defined(linux_HOST_OS)++foreign import ccall unsafe "readlink"+    c_readlink :: CString -> CString -> CSize -> IO CInt++-- | Reads the @FilePath@ pointed to by the symbolic link and returns+-- it.+--+-- See readlink(2)+readSymbolicLink :: FilePath -> IO FilePath+readSymbolicLink file =+    allocaArray0 4096 $ \buf -> do+        withFilePath file $ \s -> do+            len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $+                   c_readlink s buf 4096+            peekFilePathLen (buf,fromIntegral len)++getExecutablePath = readSymbolicLink $ "/proc/self/exe"++--------------------------------------------------------------------------------+-- Windows++#elif defined(mingw32_HOST_OS)++# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif++foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"+    c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32++getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32+  where+    go size = allocaArray (fromIntegral size) $ \ buf -> do+        ret <- c_GetModuleFileName nullPtr buf size+        case ret of+            0 -> error "getExecutablePath: GetModuleFileNameW returned an error"+            _ | ret < size -> peekFilePath buf+              | otherwise  -> go (size * 2)++--------------------------------------------------------------------------------+-- Fallback to argv[0]++#else++foreign import ccall unsafe "getFullProgArgv"+    c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()++getExecutablePath =+    alloca $ \ p_argc ->+    alloca $ \ p_argv -> do+        c_getFullProgArgv p_argc p_argv+        argc <- peek p_argc+        if argc > 0+            -- If argc > 0 then argv[0] is guaranteed by the standard+            -- to be a pointer to a null-terminated string.+            then peek p_argv >>= peek >>= peekFilePath+            else error $ "getExecutablePath: " ++ msg+  where msg = "no OS specific implementation and program name couldn't be " +++              "found in argv"++--------------------------------------------------------------------------------++#endif

+ Distribution/Client/Compat/Process.hs view

@@ -0,0 +1,48 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Compat.Process+-- Copyright   :  (c) 2013 Liu Hao, Brent Yorgey+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Cross-platform utilities for invoking processes.+--+-----------------------------------------------------------------------------++module Distribution.Client.Compat.Process (+  readProcessWithExitCode+) where++#if !MIN_VERSION_base(4,6,0)+import           Prelude           hiding (catch)+#endif++import           Control.Exception (catch, throw)+import           System.Exit       (ExitCode (ExitFailure))+import           System.IO.Error   (isDoesNotExistError)+import qualified System.Process    as P++-- | @readProcessWithExitCode@ creates an external process, reads its+--   standard output and standard error strictly, waits until the+--   process terminates, and then returns the @ExitCode@ of the+--   process, the standard output, and the standard error.+--+--   See the documentation of the version from @System.Process@ for+--   more information.+--+--   The version from @System.Process@ behaves inconsistently across+--   platforms when an executable with the given name is not found: in+--   some cases it returns an @ExitFailure@, in others it throws an+--   exception.  This variant catches \"does not exist\" exceptions and+--   turns them into @ExitFailure@s.+readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String)+readProcessWithExitCode cmd args input =+  P.readProcessWithExitCode cmd args input+    `catch` \e -> if isDoesNotExistError e+                    then return (ExitFailure 127, "", "")+                    else throw e

Distribution/Client/Config.hs view

@@ -30,16 +30,18 @@     commentSavedConfig,     initialSavedConfig,     configFieldDescriptions,-    installDirsFields+    haddockFlagsFields,+    installDirsFields,+    withProgramsFields,+    withProgramOptionsFields   ) where - import Distribution.Client.Types          ( RemoteRepo(..), Username(..), Password(..) ) import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Setup-         ( GlobalFlags(..), globalCommand+         ( GlobalFlags(..), globalCommand, defaultGlobalFlags          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags          , InstallFlags(..), installOptions, defaultInstallFlags          , UploadFlags(..), uploadCommand@@ -50,6 +52,7 @@          ( OptimisationLevel(..) ) import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags+         , HaddockFlags(..), haddockOptions, defaultHaddockFlags          , installDirsOptions          , programConfigurationPaths', programConfigurationOptions          , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault )@@ -119,7 +122,8 @@     savedUserInstallDirs   :: InstallDirs (Flag PathTemplate),     savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),     savedUploadFlags       :: UploadFlags,-    savedReportFlags       :: ReportFlags+    savedReportFlags       :: ReportFlags,+    savedHaddockFlags      :: HaddockFlags   }  instance Monoid SavedConfig where@@ -131,182 +135,21 @@     savedUserInstallDirs   = mempty,     savedGlobalInstallDirs = mempty,     savedUploadFlags       = mempty,-    savedReportFlags       = mempty+    savedReportFlags       = mempty,+    savedHaddockFlags      = mempty   }   mappend a b = SavedConfig {-    savedGlobalFlags       = combinedSavedGlobalFlags,-    savedInstallFlags      = combinedSavedInstallFlags,-    savedConfigureFlags    = combinedSavedConfigureFlags,-    savedConfigureExFlags  = combinedSavedConfigureExFlags,-    savedUserInstallDirs   = combinedSavedUserInstallDirs,-    savedGlobalInstallDirs = combinedSavedGlobalInstallDirs,-    savedUploadFlags       = combinedSavedUploadFlags,-    savedReportFlags       = combinedSavedReportFlags+    savedGlobalFlags       = combine savedGlobalFlags,+    savedInstallFlags      = combine savedInstallFlags,+    savedConfigureFlags    = combine savedConfigureFlags,+    savedConfigureExFlags  = combine savedConfigureExFlags,+    savedUserInstallDirs   = combine savedUserInstallDirs,+    savedGlobalInstallDirs = combine savedGlobalInstallDirs,+    savedUploadFlags       = combine savedUploadFlags,+    savedReportFlags       = combine savedReportFlags,+    savedHaddockFlags      = combine savedHaddockFlags   }-    where-      -- This is ugly, but necessary. If we're mappending two config files, we-      -- want the values of the *non-empty* list fields from the second one to-      -- *override* the corresponding values from the first one. Default-      -- behaviour (concatenation) is confusing and makes some use cases (see-      -- #1884) impossible.-      ---      -- However, we also want to allow specifying multiple values for a list-      -- field in a *single* config file. For example, we want the following to-      -- continue to work:-      ---      -- remote-repo: hackage.haskell.org:http://hackage.haskell.org/-      -- remote-repo: private-collection:http://hackage.local/-      ---      -- So we can't just wrap the list fields inside Flags; we have to do some-      -- special-casing just for SavedConfig.--      -- NB: the signature prevents us from using 'combine' on lists.-      combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a-      combine'        field subfield =-        (subfield . field $ a) `mappend` (subfield . field $ b)--      lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a]-      lastNonEmpty'   field subfield =-        let a' = subfield . field $ a-            b' = subfield . field $ b-        in case b' of [] -> a'-                      _  -> b'--      lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> [a])-                      -> [a]-      lastNonEmptyNL' field subfield =-        let a' = subfield . field $ a-            b' = subfield . field $ b-        in case b' of [] -> a'-                      _  -> b'--      combinedSavedGlobalFlags = GlobalFlags {-        globalVersion           = combine globalVersion,-        globalNumericVersion    = combine globalNumericVersion,-        globalConfigFile        = combine globalConfigFile,-        globalSandboxConfigFile = combine globalSandboxConfigFile,-        globalRemoteRepos       = lastNonEmptyNL globalRemoteRepos,-        globalCacheDir          = combine globalCacheDir,-        globalLocalRepos        = lastNonEmptyNL globalLocalRepos,-        globalLogsDir           = combine globalLogsDir,-        globalWorldFile         = combine globalWorldFile-        }-        where-          combine        = combine'        savedGlobalFlags-          lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags--      combinedSavedInstallFlags = InstallFlags {-        installDocumentation         = combine installDocumentation,-        installHaddockIndex          = combine installHaddockIndex,-        installDryRun                = combine installDryRun,-        installMaxBackjumps          = combine installMaxBackjumps,-        installReorderGoals          = combine installReorderGoals,-        installIndependentGoals      = combine installIndependentGoals,-        installShadowPkgs            = combine installShadowPkgs,-        installStrongFlags           = combine installStrongFlags,-        installReinstall             = combine installReinstall,-        installAvoidReinstalls       = combine installAvoidReinstalls,-        installOverrideReinstall     = combine installOverrideReinstall,-        installUpgradeDeps           = combine installUpgradeDeps,-        installOnly                  = combine installOnly,-        installOnlyDeps              = combine installOnlyDeps,-        installRootCmd               = combine installRootCmd,-        installSummaryFile           = lastNonEmptyNL installSummaryFile,-        installLogFile               = combine installLogFile,-        installBuildReports          = combine installBuildReports,-        installSymlinkBinDir         = combine installSymlinkBinDir,-        installOneShot               = combine installOneShot,-        installNumJobs               = combine installNumJobs-        }-        where-          combine        = combine'        savedInstallFlags-          lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags--      combinedSavedConfigureFlags = ConfigFlags {-        configPrograms            = configPrograms . savedConfigureFlags $ b,-        -- TODO: NubListify-        configProgramPaths        = lastNonEmpty configProgramPaths,-        -- TODO: NubListify-        configProgramArgs         = lastNonEmpty configProgramArgs,-        configProgramPathExtra    = lastNonEmptyNL configProgramPathExtra,-        configHcFlavor            = combine configHcFlavor,-        configHcPath              = combine configHcPath,-        configHcPkg               = combine configHcPkg,-        configVanillaLib          = combine configVanillaLib,-        configProfLib             = combine configProfLib,-        configSharedLib           = combine configSharedLib,-        configDynExe              = combine configDynExe,-        configProfExe             = combine configProfExe,-        -- TODO: NubListify-        configConfigureArgs       = lastNonEmpty configConfigureArgs,-        configOptimization        = combine configOptimization,-        configProgPrefix          = combine configProgPrefix,-        configProgSuffix          = combine configProgSuffix,-        -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.-        configInstallDirs         =-          (configInstallDirs . savedConfigureFlags $ a)-          `mappend` (configInstallDirs . savedConfigureFlags $ b),-        configScratchDir          = combine configScratchDir,-        -- TODO: NubListify-        configExtraLibDirs        = lastNonEmpty configExtraLibDirs,-        -- TODO: NubListify-        configExtraIncludeDirs    = lastNonEmpty configExtraIncludeDirs,-        configDistPref            = combine configDistPref,-        configVerbosity           = combine configVerbosity,-        configUserInstall         = combine configUserInstall,-        -- TODO: NubListify-        configPackageDBs          = lastNonEmpty configPackageDBs,-        configGHCiLib             = combine configGHCiLib,-        configSplitObjs           = combine configSplitObjs,-        configStripExes           = combine configStripExes,-        configConstraints         = lastNonEmpty configConstraints,-        configConfigurationsFlags = lastNonEmpty configConfigurationsFlags,-        configTests               = combine configTests,-        configBenchmarks          = combine configBenchmarks,-        configLibCoverage         = combine configLibCoverage-        }-        where-          combine        = combine'        savedConfigureFlags-          lastNonEmpty   = lastNonEmpty'   savedConfigureFlags-          lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags--      combinedSavedConfigureExFlags = ConfigExFlags {-        configCabalVersion  = combine configCabalVersion,-        -- TODO: NubListify-        configExConstraints = lastNonEmpty configExConstraints,-        -- TODO: NubListify-        configPreferences   = lastNonEmpty configPreferences,-        configSolver        = combine configSolver-        }-        where-          combine      = combine' savedConfigureExFlags-          lastNonEmpty = lastNonEmpty' savedConfigureExFlags--      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.-      combinedSavedUserInstallDirs = savedUserInstallDirs a-                                     `mappend` savedUserInstallDirs b--      -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.-      combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a-                                       `mappend` savedGlobalInstallDirs b--      combinedSavedUploadFlags = UploadFlags {-        uploadCheck     = combine uploadCheck,-        uploadUsername  = combine uploadUsername,-        uploadPassword  = combine uploadPassword,-        uploadVerbosity = combine uploadVerbosity-        }-        where-          combine = combine' savedUploadFlags--      combinedSavedReportFlags = ReportFlags {-        reportUsername  = combine reportUsername,-        reportPassword  = combine reportPassword,-        reportVerbosity = combine reportVerbosity-        }-        where-          combine = combine' savedReportFlags-+    where combine field = field a `mappend` field b  updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig updateInstallDirs userInstallFlag@@ -511,7 +354,7 @@   userInstallDirs   <- defaultInstallDirs defaultCompiler True True   globalInstallDirs <- defaultInstallDirs defaultCompiler False True   return SavedConfig {-    savedGlobalFlags       = commandDefaultFlags globalCommand,+    savedGlobalFlags       = defaultGlobalFlags,     savedInstallFlags      = defaultInstallFlags,     savedConfigureExFlags  = defaultConfigExFlags,     savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {@@ -520,7 +363,8 @@     savedUserInstallDirs   = fmap toFlag userInstallDirs,     savedGlobalInstallDirs = fmap toFlag globalInstallDirs,     savedUploadFlags       = commandDefaultFlags uploadCommand,-    savedReportFlags       = commandDefaultFlags reportCommand+    savedReportFlags       = commandDefaultFlags reportCommand,+    savedHaddockFlags      = defaultHaddockFlags   }  -- | All config file fields.@@ -534,7 +378,8 @@    ++ toSavedConfig liftConfigFlag        (configureOptions ParseArgs)-       (["builddir", "configure-option", "constraint"] ++ map fieldName installDirsFields)+       (["builddir", "configure-option", "constraint", "dependency"]+        ++ map fieldName installDirsFields)          --FIXME: this is only here because viewAsFieldDescr gives us a parser         -- that only recognises 'ghc' etc, the case-sensitive flag names, not@@ -584,7 +429,7 @@   ++ toSavedConfig liftReportFlag        (commandOptions reportCommand ParseArgs)        ["verbose", "username", "password"] []-       --FIXME: this is a hack, hiding the username and password.+       --FIXME: this is a hack, hiding the user name and password.        -- But otherwise it masks the upload ones. Either need to        -- share the options or make then distinct. In any case        -- they should probably be per-server.@@ -670,18 +515,25 @@   config <- parse others   let user0   = savedUserInstallDirs config       global0 = savedGlobalInstallDirs config-  (user, global, paths, args) <--    foldM parseSections (user0, global0, [], []) knownSections+  (haddockFlags, user, global, paths, args) <-+    foldM parseSections+          (savedHaddockFlags config, user0, global0, [], [])+          knownSections   return config {     savedConfigureFlags    = (savedConfigureFlags config) {        configProgramPaths  = paths,        configProgramArgs   = args        },+    savedHaddockFlags      = haddockFlags {+       haddockProgramPaths = paths,+       haddockProgramArgs  = args+       },     savedUserInstallDirs   = user,     savedGlobalInstallDirs = global   }    where+    isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True     isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True     isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True     isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True@@ -690,26 +542,34 @@     parse = parseFields (configFieldDescriptions                       ++ deprecatedFieldDescriptions) initial -    parseSections accum@(u,g,p,a) (ParseUtils.Section _ "install-dirs" name fs)+    parseSections accum@(h,u,g,p,a)+                 (ParseUtils.Section _ "haddock" name fs)+      | name == ""        = do h' <- parseFields haddockFlagsFields h fs+                               return (h', u, g, p, a)+      | otherwise         = do+          warning "The 'haddock' section should be unnamed"+          return accum+    parseSections accum@(h,u,g,p,a)+                  (ParseUtils.Section _ "install-dirs" name fs)       | name' == "user"   = do u' <- parseFields installDirsFields u fs-                               return (u', g, p, a)+                               return (h, u', g, p, a)       | name' == "global" = do g' <- parseFields installDirsFields g fs-                               return (u, g', p, a)+                               return (h, u, g', p, a)       | otherwise         = do-          warning "The install-paths section should be for 'user' or 'global'"+          warning "The 'install-paths' section should be for 'user' or 'global'"           return accum       where name' = lowercase name-    parseSections accum@(u,g,p,a)+    parseSections accum@(h,u,g,p,a)                  (ParseUtils.Section _ "program-locations" name fs)       | name == ""        = do p' <- parseFields withProgramsFields p fs-                               return (u, g, p', a)+                               return (h, u, g, p', a)       | otherwise         = do           warning "The 'program-locations' section should be unnamed"           return accum-    parseSections accum@(u, g, p, a)+    parseSections accum@(h, u, g, p, a)                   (ParseUtils.Section _ "program-default-options" name fs)       | name == ""        = do a' <- parseFields withProgramOptionsFields a fs-                               return (u, g, p, a')+                               return (h, u, g, p, a')       | otherwise         = do           warning "The 'program-default-options' section should be unnamed"           return accum@@ -724,6 +584,9 @@ showConfigWithComments comment vals = Disp.render $       ppFields configFieldDescriptions mcomment vals   $+$ Disp.text ""+  $+$ ppSection "haddock" "" haddockFlagsFields+                (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)+  $+$ Disp.text ""   $+$ installDirsSection "user"   savedUserInstallDirs   $+$ Disp.text ""   $+$ installDirsSection "global" savedGlobalInstallDirs@@ -743,9 +606,19 @@                (fmap (field . savedConfigureFlags) mcomment)                ((field . savedConfigureFlags) vals) -+-- | Fields for the 'install-dirs' sections. installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions++-- | Fields for the 'haddock' section.+haddockFlagsFields :: [FieldDescr HaddockFlags]+haddockFlagsFields = [ field+                     | opt <- haddockOptions ParseArgs+                     , let field = viewAsFieldDescr opt+                           name  = fieldName field+                     , name `notElem` exclusions ]+  where+    exclusions = ["verbose", "builddir"]  -- | Fields for the 'program-locations' section. withProgramsFields :: [FieldDescr [(String, FilePath)]]

Distribution/Client/Configure.hs view

@@ -12,9 +12,11 @@ ----------------------------------------------------------------------------- module Distribution.Client.Configure (     configure,+    chooseCabalVersion,   ) where  import Distribution.Client.Dependency+import Distribution.Client.Dependency.Types (AllowNewer(..), isAllowNewer) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.IndexUtils as IndexUtils@@ -36,6 +38,7 @@ import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Utils          ( defaultPackageDesc )+import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package          ( Package(..), packageName, Dependency(..), thisPackageVersion ) import Distribution.PackageDescription.Parse@@ -45,14 +48,29 @@ import Distribution.Version          ( anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils-         ( notice, info, debug, die )+         ( notice, debug, die ) import Distribution.System          ( Platform ) import Distribution.Verbosity as Verbosity          ( Verbosity )+import Distribution.Version+         ( Version(..), VersionRange, orLaterVersion )  import Data.Monoid (Monoid(..)) +-- | Choose the Cabal version such that the setup scripts compiled against this+-- version will support the given command-line flags.+chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange+chooseCabalVersion configExFlags maybeVersion =+  maybe defaultVersionRange thisVersion maybeVersion+  where+    allowNewer = fromFlagOrDefault False $+                 fmap isAllowNewer (configAllowNewer configExFlags)++    defaultVersionRange = if allowNewer+                          then orLaterVersion (Version [1,19,2] [])+                          else anyVersion+ -- | Configure the package found in the local directory configure :: Verbosity           -> PackageDBStack@@ -77,13 +95,10 @@   maybePlan <- foldProgress logMsg (return . Left) (return . Right)                             progress   case maybePlan of-    Left message -> do-      info verbosity message-      setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing-        configureCommand (const configFlags) extraArgs+    Left message -> die message      Right installPlan -> case InstallPlan.ready installPlan of-      [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] ->+      [pkg@(ReadyPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] ->         configurePackage verbosity           (InstallPlan.planPlatform installPlan)           (InstallPlan.planCompiler installPlan)@@ -95,7 +110,7 @@    where     setupScriptOptions index = SetupScriptOptions {-      useCabalVersion  = maybe anyVersion thisVersion+      useCabalVersion  = chooseCabalVersion configExFlags                          (flagToMaybe (configCabalVersion configExFlags)),       useCompiler      = Just comp,       usePlatform      = Just platform,@@ -150,16 +165,18 @@         fromFlagOrDefault False $ configBenchmarks configFlags        resolverParams =+          removeUpperBounds (fromFlagOrDefault AllowNewerNone $+                             configAllowNewer configExFlags) -          addPreferences+        . addPreferences             -- preferences from the config file or command line             [ PackageVersionPreference name ver             | Dependency name ver <- configPreferences configExFlags ]          . addConstraints             -- version constraints from the config file or command line-            -- TODO: should warn or error on constraints that are not on direct deps-            -- or flag constraints not on the package in question.+            -- TODO: should warn or error on constraints that are not on direct+            -- deps or flag constraints not on the package in question.             (map userToPackageConstraint (configExConstraints configExFlags))          . addConstraints@@ -184,20 +201,22 @@   -- | Call an installer for an 'SourcePackage' but override the configure--- flags with the ones given by the 'ConfiguredPackage'. In particular the--- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly+-- flags with the ones given by the 'ReadyPackage'. In particular the+-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly -- versioned package dependencies. So we ignore any previous partial flag -- assignment or dependency constraints and use the new ones. --+-- NB: when updating this function, don't forget to also update+-- 'installReadyPackage' in D.C.Install. configurePackage :: Verbosity                  -> Platform -> CompilerId                  -> SetupScriptOptions                  -> ConfigFlags-                 -> ConfiguredPackage+                 -> ReadyPackage                  -> [String]                  -> IO () configurePackage verbosity platform comp scriptOptions configFlags-  (ConfiguredPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs =+  (ReadyPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs =    setupWrapper verbosity     scriptOptions (Just pkg) configureCommand configureFlags extraArgs@@ -205,14 +224,23 @@   where     configureFlags   = filterConfigureFlags configFlags {       configConfigurationsFlags = flags,-      configConstraints         = map thisPackageVersion deps,-      configVerbosity           = toFlag verbosity,-      configBenchmarks          = toFlag (BenchStanzas `elem` stanzas),-      configTests               = toFlag (TestStanzas `elem` stanzas)+      -- We generate the legacy constraints as well as the new style precise+      -- deps.  In the end only one set gets passed to Setup.hs configure,+      -- depending on the Cabal version we are talking to.+      configConstraints  = [ thisPackageVersion (packageId deppkg)+                           | deppkg <- deps ],+      configDependencies = [ (packageName (Installed.sourcePackageId deppkg),+                              Installed.installedPackageId deppkg)+                           | deppkg <- deps ],+      -- Use '--exact-configuration' if supported.+      configExactConfiguration = toFlag True,+      configVerbosity          = toFlag verbosity,+      configBenchmarks         = toFlag (BenchStanzas `elem` stanzas),+      configTests              = toFlag (TestStanzas `elem` stanzas)     }      pkg = case finalizePackageDescription flags            (const True)            platform comp [] (enableStanzas stanzas gpkg) of-      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Left _ -> error "finalizePackageDescription ReadyPackage failed"       Right (desc, _) -> desc

Distribution/Client/Dependency.hs view

@@ -37,7 +37,7 @@     applySandboxInstallPolicy,      -- ** Extra policy options-    dontUpgradeBasePackage,+    dontUpgradeNonUpgradeablePackages,     hideBrokenInstalledPackages,     upgradeDependencies,     reinstallTargets,@@ -50,12 +50,12 @@     setIndependentGoals,     setAvoidReinstalls,     setShadowPkgs,-    setStrongFlags,     setMaxBackjumps,     addSourcePackages,     hideInstalledPackagesSpecificByInstalledPackageId,     hideInstalledPackagesSpecificBySourcePackageId,     hideInstalledPackagesAllVersions,+    removeUpperBounds   ) where  import Distribution.Client.Dependency.TopDown@@ -71,7 +71,7 @@          , SourcePackage(..) ) import Distribution.Client.Dependency.Types          ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)-         , PackagePreferences(..), InstalledPreference(..)+         , AllowNewer(..), PackagePreferences(..), InstalledPreference(..)          , PackagesPreferenceDefault(..)          , Progress(..), foldProgress ) import Distribution.Client.Sandbox.Types@@ -81,9 +81,14 @@ import Distribution.Package          ( PackageName(..), PackageId, Package(..), packageName, packageVersion          , InstalledPackageId, Dependency(Dependency))+import qualified Distribution.PackageDescription as PD+         ( PackageDescription(..), GenericPackageDescription(..)+         , Library(..), Executable(..), TestSuite(..), Benchmark(..), CondTree)+import Distribution.PackageDescription (BuildInfo(targetBuildDepends))+import Distribution.PackageDescription.Configuration (mapCondTree) import Distribution.Version          ( Version(..), VersionRange, anyVersion, thisVersion, withinRange-         , simplifyVersionRange )+         , removeUpperBound, simplifyVersionRange ) import Distribution.Compiler          ( CompilerId(..), CompilerFlavor(..) ) import Distribution.System@@ -120,7 +125,6 @@        depResolverIndependentGoals  :: Bool,        depResolverAvoidReinstalls   :: Bool,        depResolverShadowPkgs        :: Bool,-       depResolverStrongFlags       :: Bool,        depResolverMaxBackjumps      :: Maybe Int      } @@ -154,7 +158,6 @@        depResolverIndependentGoals  = False,        depResolverAvoidReinstalls   = False,        depResolverShadowPkgs        = False,-       depResolverStrongFlags       = False,        depResolverMaxBackjumps      = Nothing      } @@ -212,30 +215,27 @@       depResolverShadowPkgs = b     } -setStrongFlags :: Bool -> DepResolverParams -> DepResolverParams-setStrongFlags b params =-    params {-      depResolverStrongFlags = b-    }- setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams setMaxBackjumps n params =     params {       depResolverMaxBackjumps = n     } -dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams-dontUpgradeBasePackage params =+-- | Some packages are specific to a given compiler version and should never be+-- upgraded.+dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams+dontUpgradeNonUpgradeablePackages params =     addConstraints extraConstraints params   where     extraConstraints =       [ PackageConstraintInstalled pkgname       | all (/=PackageName "base") (depResolverTargets params)-      , pkgname <-  [ PackageName "base", PackageName "ghc-prim" ]+      , pkgname <- map PackageName [ "base", "ghc-prim", "integer-gmp"+                                   , "integer-simple", "template-haskell" ]       , isInstalled pkgname ]     -- TODO: the top down resolver chokes on the base constraints     -- below when there are no targets and thus no dep on base.-    -- Need to refactor contraints separate from needing packages.+    -- Need to refactor constraints separate from needing packages.     isInstalled = not . null                 . InstalledPackageIndex.lookupPackageName                                  (depResolverInstalledPkgIndex params)@@ -293,7 +293,89 @@            . InstalledPackageIndex.brokenPackages            $ depResolverInstalledPkgIndex params +-- | Remove upper bounds in dependencies using the policy specified by the+-- 'AllowNewer' argument (all/some/none).+removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams+removeUpperBounds allowNewer params =+    params {+      -- NB: It's important to apply 'removeUpperBounds' after+      -- 'addSourcePackages'. Otherwise, the packages inserted by+      -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. +      depResolverSourcePkgIndex = sourcePkgIndex'+    }+  where+    sourcePkgIndex  = depResolverSourcePkgIndex params+    sourcePkgIndex' = case allowNewer of+      AllowNewerNone      -> sourcePkgIndex+      AllowNewerAll       -> fmap relaxAllPackageDeps         sourcePkgIndex+      AllowNewerSome pkgs -> fmap (relaxSomePackageDeps pkgs) sourcePkgIndex++    relaxAllPackageDeps :: SourcePackage -> SourcePackage+    relaxAllPackageDeps = onAllBuildDepends doRelax+      where+        doRelax (Dependency pkgName verRange) =+          Dependency pkgName (removeUpperBound verRange)++    relaxSomePackageDeps :: [PackageName] -> SourcePackage -> SourcePackage+    relaxSomePackageDeps pkgNames = onAllBuildDepends doRelax+      where+        doRelax d@(Dependency pkgName verRange)+          | pkgName `elem` pkgNames = Dependency pkgName+                                      (removeUpperBound verRange)+          | otherwise               = d++    -- Walk a 'GenericPackageDescription' and apply 'f' to all 'build-depends'+    -- fields.+    onAllBuildDepends :: (Dependency -> Dependency)+                      -> SourcePackage -> SourcePackage+    onAllBuildDepends f srcPkg = srcPkg'+      where+        gpd        = packageDescription srcPkg+        pd         = PD.packageDescription gpd+        condLib    = PD.condLibrary        gpd+        condExes   = PD.condExecutables    gpd+        condTests  = PD.condTestSuites     gpd+        condBenchs = PD.condBenchmarks     gpd++        f' = onBuildInfo f+        onBuildInfo g bi = bi+          { targetBuildDepends = map g (targetBuildDepends bi) }++        onLibrary    lib  = lib { PD.libBuildInfo  = f' $ PD.libBuildInfo  lib }+        onExecutable exe  = exe { PD.buildInfo     = f' $ PD.buildInfo     exe }+        onTestSuite  tst  = tst { PD.testBuildInfo = f' $ PD.testBuildInfo tst }+        onBenchmark  bmk  = bmk { PD.benchmarkBuildInfo =+                                     f' $ PD.benchmarkBuildInfo bmk }++        srcPkg' = srcPkg { packageDescription = gpd' }+        gpd'    = gpd {+          PD.packageDescription = pd',+          PD.condLibrary        = condLib',+          PD.condExecutables    = condExes',+          PD.condTestSuites     = condTests',+          PD.condBenchmarks     = condBenchs'+          }+        pd' = pd {+          PD.buildDepends = map  f            (PD.buildDepends pd),+          PD.library      = fmap onLibrary    (PD.library pd),+          PD.executables  = map  onExecutable (PD.executables pd),+          PD.testSuites   = map  onTestSuite  (PD.testSuites pd),+          PD.benchmarks   = map  onBenchmark  (PD.benchmarks pd)+          }+        condLib'    = fmap (onCondTree onLibrary)             condLib+        condExes'   = map  (mapSnd $ onCondTree onExecutable) condExes+        condTests'  = map  (mapSnd $ onCondTree onTestSuite)  condTests+        condBenchs' = map  (mapSnd $ onCondTree onBenchmark)  condBenchs++        mapSnd :: (a -> b) -> (c,a) -> (c,b)+        mapSnd = fmap++        onCondTree :: (a -> b) -> PD.CondTree v [Dependency] a+                   -> PD.CondTree v [Dependency] b+        onCondTree g = mapCondTree g (map f) id++ upgradeDependencies :: DepResolverParams -> DepResolverParams upgradeDependencies = setPreferenceDefault PreferAllLatest @@ -384,7 +466,7 @@   return chosenSolver  runSolver :: Solver -> SolverConfig -> DependencyResolver-runSolver TopDown = const topDownResolver -- TODO: warn about unsuported options+runSolver TopDown = const topDownResolver -- TODO: warn about unsupported options runSolver Modular = modularResolver  -- | Run the dependency solver.@@ -399,7 +481,7 @@                     -> DepResolverParams                     -> Progress String String InstallPlan -    --TODO: is this needed here? see dontUpgradeBasePackage+    --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages resolveDependencies platform comp _solver params   | null (depResolverTargets params)   = return (mkInstallPlan platform comp [])@@ -408,7 +490,7 @@      fmap (mkInstallPlan platform comp)   $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls-                      shadowing strFlags maxBkjumps)+                      shadowing maxBkjumps)                      platform comp installedPkgIndex sourcePkgIndex                      preferences constraints targets   where@@ -421,13 +503,12 @@       indGoals       noReinstalls       shadowing-      strFlags-      maxBkjumps      = dontUpgradeBasePackage+      maxBkjumps      = dontUpgradeNonUpgradeablePackages                       -- TODO:                       -- The modular solver can properly deal with broken                       -- packages and won't select them. So the                       -- 'hideBrokenInstalledPackages' function should be moved-                      -- into a module that is specific to the Topdown solver.+                      -- into a module that is specific to the top-down solver.                       . (if solver /= Modular then hideBrokenInstalledPackages                                               else id)                       $ params@@ -435,7 +516,6 @@     preferences = interpretPackagesPreference                     (Set.fromList targets) defpref prefs - -- | Make an install plan from the output of the dep resolver. -- It checks that the plan is valid, or it's an error in the dep resolver. --@@ -497,7 +577,7 @@ -- It is suitable for tasks such as selecting packages to download for user -- inspection. It is not suitable for selecting packages to install. ----- Note: if no installed package index is available, it is ok to pass 'mempty'.+-- Note: if no installed package index is available, it is OK to pass 'mempty'. -- It simply means preferences for installed packages will be ignored. -- resolveWithoutDependencies :: DepResolverParams@@ -505,7 +585,7 @@ resolveWithoutDependencies (DepResolverParams targets constraints                               prefs defpref installedPkgIndex sourcePkgIndex                               _reorderGoals _indGoals _avoidReinstalls-                              _shadowing _strFlags _maxBjumps) =+                              _shadowing _maxBjumps) =     collectEithers (map selectPackage targets)   where     selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage

Distribution/Client/Dependency/Modular.hs view

@@ -41,7 +41,7 @@   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 cid (shadowPkgs 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/Builder.hs view

@@ -46,9 +46,6 @@     go :: RevDepMap -> PSQ OpenGoal () -> [OpenGoal] -> BuildState     go g o []                                             = s { rdeps = g, open = o }     go g o (ng@(OpenGoal (Flagged _ _ _ _)    _gr) : ngs) = go g (cons ng () o) ngs-      -- Note: for 'Flagged' goals, we always insert, so later additions win.-      -- This is important, because in general, if a goal is inserted twice,-      -- the later addition will have better dependency information.     go g o (ng@(OpenGoal (Stanza  _   _  )    _gr) : ngs) = go g (cons ng () o) ngs     go g o (ng@(OpenGoal (Simple (Dep qpn _)) _gr) : ngs)       | qpn == qpn'                                       = go                       g              o  ngs@@ -72,34 +69,11 @@ scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s   where     sc     = scope s-    -- Qualify all package names     qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names-    -- Introduce all package flags     qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs-    -- Combine new package and flag goals-    gs     = L.map (flip OpenGoal gr) (qfdefs ++ qfdeps)-    -- NOTE:-    ---    -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially-    -- multiple times, both via the flag declaration and via dependencies.-    -- The order is potentially important, because the occurrences via-    -- dependencies may record flag-dependency information. After a number-    -- of bugs involving computing this information incorrectly, however,-    -- we're currently not using carefully computed inter-flag dependencies-    -- anymore, but instead use 'simplifyVar' when computing conflict sets-    -- to map all flags of one package to a single flag for conflict set-    -- purposes, thereby treating them all as interdependent.-    ---    -- If we ever move to a more clever algorithm again, then the line above-    -- needs to be looked at very carefully, and probably be replaced by-    -- more systematically computed flag dependency information.+    gs     = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs) --- | Datatype that encodes what to build next-data BuildType =-    Goals                                  -- ^ build a goal choice node-  | OneGoal OpenGoal                       -- ^ build a node for this goal-  | Instance QPN I PInfo QGoalReasonChain  -- ^ build a tree for a concrete instance-  deriving Show+data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasonChain  build :: BuildState -> Tree (QGoalReasonChain, Scope) build = ana go@@ -131,8 +105,8 @@     -- that is indicated by the flag default.     --     -- TODO: Should we include the flag default in the tree?-    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =-      FChoiceF qfn (gr, sc) (w || trivial) m (P.fromList (reorder b+    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m) t f) gr) }) =+      FChoiceF qfn (gr, sc) trivial m (P.fromList (reorder b         [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True  : gr)) t) bs) { next = Goals }),          (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))       where

Distribution/Client/Dependency/Modular/Dependency.hs view

@@ -21,16 +21,6 @@ data Var qpn = P qpn | F (FN qpn) | S (SN qpn)   deriving (Eq, Ord, Show) --- | For computing conflict sets, we map flag choice vars to a--- single flag choice. This means that all flag choices are treated--- as interdependent. So if one flag of a package ends up in a--- conflict set, then all flags are being treated as being part of--- the conflict set.-simplifyVar :: Var qpn -> Var qpn-simplifyVar (P qpn)       = P qpn-simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag"))-simplifyVar (S qsn)       = S qsn- showVar :: Var QPN -> String showVar (P qpn) = showQPN qpn showVar (F qfn) = showQFN qfn@@ -185,7 +175,7 @@ goalReasonToVars :: GoalReason qpn -> ConflictSet qpn goalReasonToVars UserGoal                 = S.empty goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)-goalReasonToVars (FDependency qfn _)      = S.singleton (simplifyVar (F qfn))+goalReasonToVars (FDependency qfn _)      = S.singleton (F qfn) goalReasonToVars (SDependency qsn)        = S.singleton (S qsn)  goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn@@ -204,4 +194,4 @@ -- | Compute a conflic set from a goal. The conflict set contains the -- closure of goal reasons as well as the variable of the goal itself. toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn-toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs)+toConflictSet (Goal g grs) = S.insert g (goalReasonChainToVars grs)

Distribution/Client/Dependency/Modular/Explore.hs view

@@ -66,9 +66,9 @@ combine _   []                      c = (Just c, []) combine var ((k, (     d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $                                         case d of-                                          Just e | not (simplifyVar var `S.member` e) -> (Just e, [])-                                                 | otherwise                          -> combine var xs (e `S.union` c)-                                          Nothing                                     -> (Nothing, snd $ combine var xs S.empty)+                                          Just e | not (var `S.member` e) -> (Just e, [])+                                                 | otherwise              -> combine var xs (e `S.union` c)+                                          Nothing                         -> (Nothing, snd $ combine var xs S.empty)  -- | Naive backtracking exploration of the search tree. This will yield correct -- assignments only once the tree itself is validated.

Distribution/Client/Dependency/Modular/Flag.hs view

@@ -25,13 +25,9 @@ unFlag :: Flag -> String unFlag (FlagName fn) = fn -mkFlag :: String -> Flag-mkFlag fn = FlagName fn---- | Flag info. Default value, whether the flag is manual, and--- whether the flag is weak. Manual flags can only be set explicitly.--- Weak flags are typically deferred by the solver.-data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: Bool }+-- | Flag info. Default value, and whether the flag is manual.+-- Manual flags can only be set explicitly.+data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool }   deriving (Eq, Ord, Show)  -- | Flag defaults.

Distribution/Client/Dependency/Modular/IndexConversion.hs view

@@ -32,16 +32,16 @@ -- 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 ->+convPIs :: OS -> Arch -> CompilerId -> 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 cid sip iidx sidx =+  mkIndex (convIPI' sip iidx ++ convSPI' os arch cid 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' sip idx =-    -- apply shadowing whenever there are multple installed packages with+    -- apply shadowing whenever there are multiple installed packages with     -- the same version     [ maybeShadow (convIP idx pkg)     | (_pkgid, pkgs) <- SI.allPackagesBySourcePackageId idx@@ -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 -> CompilerId ->             CI.PackageIndex SourcePackage -> [(PN, I, PInfo)]-convSPI' os arch cid strfl = L.map (convSP os arch cid strfl) . CI.allPackages+convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages -convSPI :: OS -> Arch -> CompilerId -> Bool ->+convSPI :: OS -> Arch -> CompilerId ->            CI.PackageIndex SourcePackage -> Index-convSPI os arch cid strfl = mkIndex . convSPI' os arch cid strfl+convSPI os arch cid = mkIndex . convSPI' os arch cid  -- | 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 -> CompilerId -> SourcePackage -> (PN, I, PInfo)+convSP os arch cid (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 cid (PI pn i) gpd)  -- We do not use 'flattenPackageDescription' or 'finalizePackageDescription' -- from 'Distribution.PackageDescription.Configuration' here, because we@@ -104,12 +104,12 @@ -- -- 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 -> CompilerId ->            PI PN -> GenericPackageDescription -> PInfo-convGPD os arch cid strfl pi+convGPD os arch cid pi         (GenericPackageDescription _ flags libs exes tests benchs) =   let-    fds = flagInfo strfl flags+    fds = flagInfo flags   in     PInfo       (maybe []    (convCondTree os arch cid pi fds (const True)          ) libs    ++@@ -126,10 +126,9 @@ prefix _ []  = [] prefix f fds = [f (concat fds)] --- | Convert flag information. Automatic flags are now considered weak--- unless strong flags have been selected explicitly.-flagInfo :: Bool -> [PD.Flag] -> FlagInfo-flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not (strfl || m))))+-- | Convert flag information.+flagInfo :: [PD.Flag] -> FlagInfo+flagInfo = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m))  -- | Convert condition trees to flagged dependencies. convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagInfo ->@@ -165,7 +164,7 @@     go (CNot c)    t f = go c f t     go (CAnd c d)  t f = go c (go d t f) f     go (COr  c d)  t f = go c t (go d t f)-    go (Var (Flag fn)) t f = extractCommon t f ++ [Flagged (FN pi fn) (fds ! fn) t f]+    go (Var (Flag fn)) t f = [Flagged (FN pi fn) (fds ! fn) t f]     go (Var (OS os')) t f       | os == os'      = t       | otherwise      = f@@ -175,14 +174,6 @@     go (Var (Impl cf' cvr')) t f       | cf == cf' && checkVR cvr' cv = t       | otherwise      = f--    -- If both branches contain the same package as a simple dep, we lift it to-    -- the next higher-level, but without constraints. This heuristic together-    -- with deferring flag choices will then usually first resolve this package,-    -- and try an already installed version before imposing a default flag choice-    -- that might not be what we want.-    extractCommon :: FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN-    extractCommon ps ps' = [ D.Simple (Dep pn (Constrained [])) | D.Simple (Dep pn _) <- ps, D.Simple (Dep pn' _) <- ps', pn == pn' ]  -- | Convert a Cabal dependency to a solver-specific dependency. convDep :: PN -> Dependency -> Dep PN

Distribution/Client/Dependency/Modular/PSQ.hs view

@@ -2,7 +2,7 @@  -- Priority search queues. ----- I am not yet sure what exactly is needed. But we need a datastructure with+-- I am not yet sure what exactly is needed. But we need a data structure with -- key-based lookup that can be sorted. We're using a sequence right now with -- (inefficiently implemented) lookup, because I think that queue-based -- operations and sorting turn out to be more efficiency-critical in practice.

Distribution/Client/Dependency/Modular/Preference.hs view

@@ -138,7 +138,7 @@     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+            (_ , [])     -> P.fromList []             (xs, y : ys) -> P.fromList (xs ++ y : L.map (\ (b, _) -> (b, Fail c ManualFlag)) ys)       where         isDisabled (_, Fail _ _) = True@@ -241,11 +241,10 @@     go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs)     go x                = x --- | Transformation that tries to avoid making weak flag choices early.--- Weak flags are trivial flags (not influencing dependencies) or such--- flags that are explicitly declared to be weak in the index.-deferWeakFlagChoices :: Tree a -> Tree a-deferWeakFlagChoices = trav go+-- | Transformation that tries to avoid making inconsequential+-- flag choices early.+deferDefaultFlagChoices :: Tree a -> Tree a+deferDefaultFlagChoices = trav go   where     go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs)     go x                = x

Distribution/Client/Dependency/Modular/Solver.hs view

@@ -21,7 +21,6 @@   independentGoals      :: Bool,   avoidReinstalls       :: Bool,   shadowPkgs            :: Bool,-  strongFlags           :: Bool,   maxBackjumps          :: Maybe Int } @@ -41,17 +40,19 @@   where     explorePhase     = exploreTreeLog . backjump     heuristicsPhase  = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)-                       P.deferWeakFlagChoices .-                       P.preferBaseGoalChoice .                        if preferEasyGoalChoices sc-                         then P.lpreferEasyGoalChoices-                         else id+                         then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices+                         else P.preferBaseGoalChoice     preferencesPhase = P.preferPackagePreferences userPrefs     validationPhase  = P.enforceManualFlags . -- can only be done after user constraints                        P.enforcePackageConstraints userConstraints .                        validateTree idx     prunePhase       = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .                        -- packages that can never be "upgraded":-                       P.requireInstalled (`elem` [PackageName "base",-                                                   PackageName "ghc-prim"])+                       P.requireInstalled (`elem` [ PackageName "base"+                                                  , PackageName "ghc-prim"+                                                  , PackageName "integer-gmp"+                                                  , PackageName "integer-simple"+                                                  , PackageName "template-haskell"+                                                  ])     buildPhase       = buildTree idx (independentGoals sc) userGoals

Distribution/Client/Dependency/Modular/Tree.hs view

@@ -15,7 +15,7 @@ -- | Type of the search tree. Inlining the choice nodes for now. data Tree a =     PChoice     QPN a           (PSQ I        (Tree a))-  | FChoice     QFN a Bool Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual+  | FChoice     QFN a Bool Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial, second Bool whether it's manual   | SChoice     QSN a Bool      (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial   | GoalChoice                  (PSQ OpenGoal (Tree a)) -- PSQ should never be empty   | Done        RevDepMap@@ -24,11 +24,6 @@   -- 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.-  ---  -- A (flag) choice is called weak if we do want to defer it. This is the-  -- case for flags that should be implied by what's currently installed on-  -- 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)

Distribution/Client/Dependency/Modular/Validate.hs view

@@ -23,7 +23,7 @@  -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints--- that for which the precondiditions are fulfilled ACTIVE. We maintain a set+-- that for which the preconditions are fulfilled ACTIVE. We maintain a set -- of currently active constraints that we pass down the node. -- -- We aim at detecting inconsistent states as early as possible.

Distribution/Client/Dependency/Modular/Version.hs view

@@ -40,4 +40,3 @@ -- | Make a version number. mkV :: [Int] -> Ver mkV xs = CV.Version xs []-

Distribution/Client/Dependency/Types.hs view

@@ -17,6 +17,7 @@     Solver(..),     DependencyResolver, +    AllowNewer(..), isAllowNewer,     PackageConstraint(..),     PackagePreferences(..),     InstalledPreference(..),@@ -129,7 +130,7 @@ -- | 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--- that are already installed. It also hase a 'PackageVersionPreference' which+-- that are already installed. It also has a 'PackageVersionPreference' which -- is a suggested constraint on the version number. The resolver should try to -- use package versions that satisfy the suggested version constraint. --@@ -167,9 +168,31 @@      --    | PreferLatestForSelected +-- | Policy for relaxing upper bounds in dependencies. For example, given+-- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper+-- bound and choose a version of 'array' that is greater or equal to 0.5? By+-- default the upper bounds are always strictly honored.+data AllowNewer =++  -- | Default: honor the upper bounds in all dependencies, never choose+  -- versions newer than allowed.+  AllowNewerNone++  -- | Ignore upper bounds in dependencies on the given packages.+  | AllowNewerSome [PackageName]++  -- | Ignore upper bounds in dependencies on all packages.+  | AllowNewerAll++-- | Convert 'AllowNewer' to a boolean.+isAllowNewer :: AllowNewer -> Bool+isAllowNewer AllowNewerNone     = False+isAllowNewer (AllowNewerSome _) = True+isAllowNewer AllowNewerAll      = True+ -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final--- retult which may be used to indicate progress and\/or logging messages.+-- result which may be used to indicate progress and\/or logging messages. -- data Progress step fail done = Step step (Progress step fail done)                              | Fail fail

Distribution/Client/Fetch.hs view

@@ -154,8 +154,6 @@        . setShadowPkgs shadowPkgs -      . setStrongFlags strongFlags-         -- Reinstall the targets given on the command line so that the dep         -- resolver will decide that they need fetching, even if they're         -- already installed. Since we want to get the source packages of@@ -170,7 +168,6 @@     reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)     independentGoals = fromFlag (fetchIndependentGoals fetchFlags)     shadowPkgs       = fromFlag (fetchShadowPkgs       fetchFlags)-    strongFlags      = fromFlag (fetchStrongFlags      fetchFlags)     maxBackjumps     = fromFlag (fetchMaxBackjumps     fetchFlags)

+ Distribution/Client/Freeze.hs view

@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Freeze+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- The cabal freeze command+-----------------------------------------------------------------------------+module Distribution.Client.Freeze (+    freeze,+  ) where++import Distribution.Client.Config ( SavedConfig(..) )+import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.Dependency hiding ( addConstraints )+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import Distribution.Client.InstallPlan+         ( PlanPackage )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.Setup+         ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..) )+import Distribution.Client.Sandbox.PackageEnvironment+         ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,+           userPackageEnvironmentFile )+import Distribution.Client.Sandbox.Types+         ( SandboxPackageInfo(..) )++import Distribution.Package+         ( Package, PackageIdentifier, packageId, packageName, packageVersion )+import Distribution.Simple.Compiler+         ( Compiler(compilerId), PackageDBStack )+import Distribution.Simple.PackageIndex (PackageIndex)+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Simple.Program+         ( ProgramConfiguration )+import Distribution.Simple.Setup+         ( fromFlag )+import Distribution.Simple.Utils+         ( die, notice, debug, writeFileAtomic )+import Distribution.System+         ( Platform )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import Control.Monad+         ( when )+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Data.Monoid+         ( mempty )+import Data.Version+         ( showVersion )+import Distribution.Version+         ( thisVersion )++-- ------------------------------------------------------------+-- * The freeze command+-- ------------------------------------------------------------++--TODO:+-- * Don't overwrite all of `cabal.config`, just the constraints section.+-- * Should the package represented by `UserTargetLocalDir "."` be+--   constrained too? What about `base`?+++-- | Freeze all of the dependencies by writing a constraints section+-- constraining each dependency to an exact version.+--+freeze :: Verbosity+      -> PackageDBStack+      -> [Repo]+      -> Compiler+      -> Platform+      -> ProgramConfiguration+      -> Maybe SandboxPackageInfo+      -> GlobalFlags+      -> FreezeFlags+      -> IO ()+freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo+      globalFlags freezeFlags = do++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repos++    pkgSpecifiers <- resolveUserTargets verbosity+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       [UserTargetLocalDir "."]++    sanityCheck pkgSpecifiers+    pkgs  <- planPackages+               verbosity comp platform mSandboxPkgInfo freezeFlags+               installedPkgIndex sourcePkgDb pkgSpecifiers++    if null pkgs+      then notice verbosity $ "No packages to be frozen. "+                           ++ "As this package has no dependencies."+      else if dryRun+             then notice verbosity $ unlines $+                     "The following packages would be frozen:"+                   : formatPkgs pkgs++             else freezePackages verbosity pkgs++  where+    dryRun = fromFlag (freezeDryRun freezeFlags)++    sanityCheck pkgSpecifiers =+      when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $+        die $ "internal error: 'resolveUserTargets' returned "+           ++ "unexpected named package specifiers!"++planPackages :: Verbosity+             -> Compiler+             -> Platform+             -> Maybe SandboxPackageInfo+             -> FreezeFlags+             -> PackageIndex+             -> SourcePackageDb+             -> [PackageSpecifier SourcePackage]+             -> IO [PlanPackage]+planPackages verbosity comp platform mSandboxPkgInfo freezeFlags+             installedPkgIndex sourcePkgDb pkgSpecifiers = do++  solver <- chooseSolver verbosity+            (fromFlag (freezeSolver freezeFlags)) (compilerId comp)+  notice verbosity "Resolving dependencies..."++  installPlan <- foldProgress logMsg die return $+                   resolveDependencies+                     platform (compilerId comp)+                     solver+                     resolverParams++  return $ either id+                  (error "planPackages: installPlan contains broken packages")+                  (pruneInstallPlan installPlan pkgSpecifiers)++  where+    resolverParams =++        setMaxBackjumps (if maxBackjumps < 0 then Nothing+                                             else Just maxBackjumps)++      . setIndependentGoals independentGoals++      . setReorderGoals reorderGoals++      . setShadowPkgs shadowPkgs++      . maybe id applySandboxInstallPolicy mSandboxPkgInfo++      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers++    logMsg message rest = debug verbosity message >> rest++    reorderGoals     = fromFlag (freezeReorderGoals     freezeFlags)+    independentGoals = fromFlag (freezeIndependentGoals freezeFlags)+    shadowPkgs       = fromFlag (freezeShadowPkgs       freezeFlags)+    maxBackjumps     = fromFlag (freezeMaxBackjumps     freezeFlags)+++-- | Remove all unneeded packages from an install plan.+--+-- A package is unneeded if it is not a dependency (directly or+-- transitively) of any of the 'PackageSpecifier SourcePackage's.  This is+-- useful for removing previously installed packages which are no longer+-- required from the install plan.+pruneInstallPlan :: InstallPlan.InstallPlan+                 -> [PackageSpecifier SourcePackage]+                 -> Either [PlanPackage] [(PlanPackage, [PackageIdentifier])]+pruneInstallPlan installPlan pkgSpecifiers =+    mapLeft PackageIndex.allPackages $+    PackageIndex.dependencyClosure pkgIdx pkgIds+  where+    pkgIdx = PackageIndex.fromList $ InstallPlan.toList installPlan+    pkgIds = [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]+    mapLeft f (Left v)  = Left $ f v+    mapLeft _ (Right v) = Right v+++freezePackages :: Package pkg => Verbosity -> [pkg] -> IO ()+freezePackages verbosity pkgs = do+    pkgEnv <- fmap (createPkgEnv . addConstraints) $ loadUserConfig verbosity ""+    writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv+  where+    addConstraints config =+        config {+            savedConfigureExFlags = (savedConfigureExFlags config) {+                configExConstraints = constraints pkgs+            }+        }+    constraints = map $ pkgIdToConstraint . packageId+      where+        pkgIdToConstraint pkg =+            UserConstraintVersion (packageName pkg)+                                  (thisVersion $ packageVersion pkg)+    createPkgEnv config = mempty { pkgEnvSavedConfig = config }+    showPkgEnv = BS.Char8.pack . showPackageEnvironment+++formatPkgs :: Package pkg => [pkg] -> [String]+formatPkgs = map $ showPkg . packageId+  where+    showPkg pid = name pid ++ " == " ++ version pid+    name = display . packageName+    version = showVersion . packageVersion

Distribution/Client/Get.hs view

@@ -37,6 +37,8 @@ import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils         ( getSourcePackages )+import Distribution.Client.Compat.Process+        ( readProcessWithExitCode ) import Distribution.Compat.Exception         ( catchIO ) @@ -62,7 +64,7 @@ import System.FilePath          ( (</>), (<.>), addTrailingPathSeparator ) import System.Process-         ( rawSystem, readProcessWithExitCode )+         ( rawSystem )   -- | Entry point for the 'cabal get' command.@@ -103,7 +105,7 @@    where     resolverParams sourcePkgDb pkgSpecifiers =-        --TODO: add commandline constraint and preference args for unpack+        --TODO: add command-line constraint and preference args for unpack         standardInstallPolicy mempty sourcePkgDb pkgSpecifiers      prefix = fromFlagOrDefault "" (getDestDir getFlags)@@ -212,7 +214,7 @@     return (Data.Map.fromList pairs)  -- | Fork a single package from a remote source repository to the local--- filesystem.+-- file system. forkPackage :: Verbosity             -> Data.Map.Map PD.RepoType Brancher                -- ^ Branchers supported by the local machine.

Distribution/Client/Haddock.hs view

@@ -16,31 +16,29 @@     )     where -import Data.Maybe (listToMaybe) import Data.List (maximumBy)-import Control.Monad (guard)-import System.Directory (createDirectoryIfMissing, doesFileExist,-                         renameFile)-import System.FilePath ((</>), splitFileName, isAbsolute)+import System.Directory (createDirectoryIfMissing, renameFile)+import System.FilePath ((</>), splitFileName) import Distribution.Package-         ( Package(..), packageVersion )+         ( packageVersion )+import Distribution.Simple.Haddock (haddockPackagePaths) import Distribution.Simple.Program (haddockProgram, ProgramConfiguration                                    , rawSystemProgram, requireProgramVersion) import Distribution.Version (Version(Version), orLaterVersion) import Distribution.Verbosity (Verbosity)-import Distribution.Text (display) import Distribution.Simple.PackageIndex          ( PackageIndex, allPackagesByName ) import Distribution.Simple.Utils-         ( comparing, intercalate, debug-         , installDirectoryContents, withTempDirectory )+         ( comparing, debug, installDirectoryContents, withTempDirectory ) import Distribution.InstalledPackageInfo as InstalledPackageInfo-         ( InstalledPackageInfo-         , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) )+         ( InstalledPackageInfo_(exposed) ) -regenerateHaddockIndex :: Verbosity -> PackageIndex -> ProgramConfiguration -> FilePath -> IO ()+regenerateHaddockIndex :: Verbosity+                       -> PackageIndex -> ProgramConfiguration -> FilePath+                       -> IO () regenerateHaddockIndex verbosity pkgs conf index = do-      (paths,warns) <- haddockPackagePaths pkgs'+      (paths, warns) <- haddockPackagePaths pkgs' Nothing+      let paths' = [ (interface, html) | (interface, Just html) <- paths]       case warns of         Nothing -> return ()         Just m  -> debug verbosity m@@ -58,7 +56,7 @@                     , "--odir=" ++ tempDir                     , "--title=Haskell modules on this system" ]                  ++ [ "--read-interface=" ++ html ++ "," ++ interface-                    | (interface, html) <- paths ]+                    | (interface, html) <- paths' ]         rawSystemProgram verbosity confHaddock flags         renameFile (tempDir </> "index.html") (tempDir </> destFile)         installDirectoryContents verbosity tempDir destDir@@ -69,41 +67,3 @@             | (_pname, pkgvers) <- allPackagesByName pkgs             , let pkgvers' = filter exposed pkgvers             , not (null pkgvers') ]--haddockPackagePaths :: [InstalledPackageInfo]-                       -> IO ([(FilePath, FilePath)], Maybe String)-haddockPackagePaths pkgs = do-  interfaces <- sequence-    [ case interfaceAndHtmlPath pkg of-        Just (interface, html) -> do-          exists <- doesFileExist interface-          if exists-            then return (pkgid, Just (interface, html))-            else return (pkgid, Nothing)-        Nothing -> return (pkgid, Nothing)-    | pkg <- pkgs, let pkgid = packageId pkg ]--  let missing = [ pkgid | (pkgid, Nothing) <- interfaces ]--      warning = "The documentation for the following packages are not "-             ++ "installed. No links will be generated to these packages: "-             ++ intercalate ", " (map display missing)--      flags = [ x | (_, Just x) <- interfaces ]--  return (flags, if null missing then Nothing else Just warning)--  where-    interfaceAndHtmlPath pkg = do-      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)-      html <- fmap fixFileUrl-                   (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))-      guard (not . null $ html)-      return (interface, html)-    -    -- the 'haddock-html' field in the hc-pkg output is often set as a-    -- native path, but we need it as a URL.-    -- See https://github.com/haskell/cabal/issues/1064-    fixFileUrl f | isAbsolute f = "file://" ++ f-                 | otherwise    = f-

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@@ -43,7 +43,7 @@  data DownloadResult = FileAlreadyInCache | FileDownloaded FilePath deriving (Eq) --- Trime+-- Trim trim :: String -> String trim = f . f       where f = reverse . dropWhile isSpace@@ -76,10 +76,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@@ -88,8 +88,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

@@ -55,7 +55,7 @@ import Distribution.Verbosity          ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils-         ( die, warn, info, fromUTF8, findPackageDesc )+         ( die, warn, info, fromUTF8, tryFindPackageDesc )  import Data.Char   (isAlphaNum) import Data.Maybe  (mapMaybe, fromMaybe)@@ -71,7 +71,7 @@ import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils (byteStringToFilePath) import Distribution.Compat.Exception (catchIO)-import Distribution.Client.Compat.Time+import Distribution.Client.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist) import System.FilePath ((</>), takeExtension, splitDirectories, normalise) import System.FilePath.Posix as FilePath.Posix@@ -93,7 +93,7 @@ convert :: InstalledPackageIndex.PackageIndex -> 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.+    -- like when the same package is installed in the global & user DBs.     -- InstalledPackageIndex.allPackagesBySourcePackageId gives us the     -- installed packages with the most preferred instances first, so by     -- picking the first we should get the user one. This is almost but not@@ -109,7 +109,7 @@     -- other packages that do not exist then we have a problem we cannot find     -- the original source package id. Instead we make up a bogus package id.     -- This should have the same effect since it should be a dependency on a-    -- non-existant package.+    -- nonexistent package.     sourceDeps index ipkg =       [ maybe (brokenPackageId depid) packageId mdep       | let depids = InstalledPackageInfo.depends ipkg@@ -281,7 +281,7 @@ -- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. -- -- This is supposed to be an \"all in one\" way to easily get at the info in--- the hackage package index.+-- the Hackage package index. -- -- It takes a function to map a 'GenericPackageDescription' into any more -- specific instance of 'Package' that you might want to use. In the simple@@ -351,7 +351,7 @@     | Tar.isBuildTreeRefTypeCode typeCode ->       Just $ do         let path   = byteStringToFilePath content-        cabalFile <- findPackageDesc path+        cabalFile <- tryFindPackageDesc path         descr     <- PackageDesc.Parse.readPackageDescription normal cabalFile         return $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)                               descr path blockNo@@ -452,7 +452,7 @@       -- 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 <- findPackageDesc path+      pkg  <- do cabalFile <- tryFindPackageDesc path                  PackageDesc.Parse.readPackageDescription normal cabalFile       let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)       accum (srcpkg:srcpkgs) prefs entries

Distribution/Client/Init.hs view

@@ -36,7 +36,7 @@ import Data.List   ( intercalate, nub, groupBy, (\\) ) import Data.Maybe-  ( fromMaybe, isJust, catMaybes )+  ( fromMaybe, isJust, catMaybes, listToMaybe ) import Data.Function   ( on ) import qualified Data.Map as M@@ -67,9 +67,10 @@ import Distribution.Client.Init.Types   ( InitFlags(..), PackageType(..), Category(..) ) import Distribution.Client.Init.Licenses-  ( bsd3, gplv2, gplv3, lgpl2, lgpl3, agplv3, apache20 )+  ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20 ) import Distribution.Client.Init.Heuristics-  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..),+  ( guessPackageName, guessAuthorNameMail, guessMainFileCandidates,+    SourceFileEntry(..),     scanForModules, neededBuildPrograms )  import Distribution.License@@ -154,7 +155,7 @@               ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)    pkgName' <-     return (flagToMaybe $ packageName flags)-              ?>> maybePrompt flags (promptStr "Package name" guess)+              ?>> maybePrompt flags (prompt "Package name" guess)               ?>> return guess    return $ flags { packageName = maybeToFlag pkgName' }@@ -266,9 +267,29 @@                                    [Library, Executable]                                    Nothing display False)            ?>> return (Just Library)+  mainFile <- if isLib /= Just Executable then return Nothing else+                    getMainFile flags -  return $ flags { packageType = maybeToFlag isLib }+  return $ flags { packageType = maybeToFlag isLib+                 , mainIs = maybeToFlag mainFile+                 } +-- | Try to guess the main file of the executable, and prompt the user to choose+-- one of them. Top-level modules including the word 'Main' in the file name+-- will be candidates, and shorter filenames will be preferred.+getMainFile :: InitFlags -> IO (Maybe FilePath)+getMainFile flags =+  return (flagToMaybe $ mainIs flags)+  ?>> do+    candidates <- guessMainFileCandidates flags+    let showCandidate = either (++" (does not yet exist)") id+        defaultFile = listToMaybe candidates+    maybePrompt flags (either id (either id id) `fmap`+                       promptList "What is the main module of the executable"+                       candidates+                       defaultFile showCandidate True)+      ?>> return (fmap (either id id) defaultFile)+ -- | Ask for the base language of the package. getLanguage :: InitFlags -> IO InitFlags getLanguage flags = do@@ -534,23 +555,24 @@ writeLicense :: InitFlags -> IO () writeLicense flags = do   message flags "\nGenerating LICENSE..."-  year <- getYear+  year <- show <$> getYear+  let authors = fromMaybe "???" . flagToMaybe . author $ flags   let licenseFile =         case license flags of-          Flag BSD3 -> Just $ bsd3 (fromMaybe "???"-                                  . flagToMaybe-                                  . author-                                  $ flags)-                              (show year)+          Flag BSD2+            -> Just $ bsd2 authors year +          Flag BSD3+            -> Just $ bsd3 authors year+           Flag (GPL (Just (Version {versionBranch = [2]})))             -> Just gplv2            Flag (GPL (Just (Version {versionBranch = [3]})))             -> Just gplv3 -          Flag (LGPL (Just (Version {versionBranch = [2]})))-            -> Just lgpl2+          Flag (LGPL (Just (Version {versionBranch = [2, 1]})))+            -> Just lgpl21            Flag (LGPL (Just (Version {versionBranch = [3]})))             -> Just lgpl3@@ -561,6 +583,12 @@           Flag (Apache (Just (Version {versionBranch = [2, 0]})))             -> Just apache20 +          Flag MIT+            -> Just $ mit authors year++          Flag (MPL (Version {versionBranch = [2, 0]}))+            -> Just mpl20+           _ -> Nothing    case licenseFile of@@ -590,7 +618,7 @@   message flags "Error: no package name provided."   return False writeCabalFile flags@(InitFlags{packageName = Flag p}) = do-  let cabalFileName = p ++ ".cabal"+  let cabalFileName = display p ++ ".cabal"   message flags $ "Generating " ++ cabalFileName ++ "..."   writeFileSafe flags cabalFileName (generateCabalFile cabalFileName flags)   return True@@ -640,7 +668,7 @@          $$ text ""     else empty)   $$-  vcat [ fieldS "name"          (packageName   c)+  vcat [ field  "name"          (packageName   c)                 (Just "The name of the package.")                 True @@ -705,8 +733,10 @@         , case packageType c of            Flag Executable ->-             text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ nest 2 (vcat-             [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True+             text "\nexecutable" <+>+             text (maybe "" display . flagToMaybe $ packageName c) $$+             nest 2 (vcat+             [ fieldS "main-is" (mainIs c) (Just ".hs or .lhs file containing the Main module.") True               , generateBuildInfo Executable c              ])

Distribution/Client/Init/Heuristics.hs view

@@ -15,15 +15,17 @@     guessPackageName,     scanForModules,     SourceFileEntry(..),     neededBuildPrograms,+    guessMainFileCandidates,     guessAuthorNameMail,     knownCategories, ) where import Distribution.Text         (simpleParse)-import Distribution.Simple.Setup (Flag(..))+import Distribution.Simple.Setup (Flag(..), flagToMaybe) import Distribution.ModuleName     ( ModuleName, toFilePath ) import Distribution.Client.PackageIndex     ( allPackagesByName )+import qualified Distribution.Package as P import qualified Distribution.PackageDescription as PD     ( category, packageDescription ) import Distribution.Simple.Utils@@ -34,25 +36,74 @@  import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) ) import Control.Applicative ( pure, (<$>), (<*>) )+import Control.Arrow ( first ) import Control.Monad ( liftM )-import Data.Char   ( isUpper, isLower, isSpace )+import Data.Char   ( isAlphaNum, isNumber, isUpper, isLower, isSpace ) import Data.Either ( partitionEithers )-import Data.List   ( isPrefixOf )+import Data.List   ( isInfixOf, isPrefixOf, isSuffixOf, sortBy ) import Data.Maybe  ( mapMaybe, catMaybes, maybeToList )-import Data.Monoid ( mempty, mconcat )+import Data.Monoid ( mempty, mappend, mconcat, )+import Data.Ord    ( comparing ) import qualified Data.Set as Set ( fromList, toList )-import System.Directory ( getDirectoryContents,+import System.Directory ( getCurrentDirectory, getDirectoryContents,                           doesDirectoryExist, doesFileExist, getHomeDirectory, ) import Distribution.Compat.Environment ( getEnvironment ) import System.FilePath ( takeExtension, takeBaseName, dropExtension,                          (</>), (<.>), splitDirectories, makeRelative )-import System.Process ( readProcessWithExitCode )++import Distribution.Client.Init.Types     ( InitFlags(..) )+import Distribution.Client.Compat.Process ( readProcessWithExitCode ) import System.Exit ( ExitCode(..) ) --- |Guess the package name based on the given root directory-guessPackageName :: FilePath -> IO String-guessPackageName = liftM (last . splitDirectories) . tryCanonicalizePath+-- | Return a list of candidate main files for this executable: top-level+-- modules including the word 'Main' in the file name. The list is sorted in+-- order of preference, shorter file names are preferred. 'Right's are existing+-- candidates and 'Left's are those that do not yet exist.+guessMainFileCandidates :: InitFlags -> IO [Either FilePath FilePath]+guessMainFileCandidates flags = do+  dir <-+    maybe getCurrentDirectory return (flagToMaybe $ packageDir flags)+  files <- getDirectoryContents dir+  let existingCandidates = filter isMain files+      -- We always want to give the user at least one default choice.  If either+      -- Main.hs or Main.lhs has already been created, then we don't want to+      -- suggest the other; however, if neither has been created, then we+      -- suggest both.+      newCandidates =+        if any (`elem` existingCandidates) ["Main.hs", "Main.lhs"]+        then []+        else ["Main.hs", "Main.lhs"]+      candidates =+        sortBy (\x y -> comparing (length . either id id) x y+                        `mappend` compare x y)+               (map Left newCandidates ++ map Right existingCandidates)+  return candidates +  where+    isMain f =    (isInfixOf "Main" f || isInfixOf  "main" f)+               && (isSuffixOf ".hs" f || isSuffixOf ".lhs" f)++-- | Guess the package name based on the given root directory.+guessPackageName :: FilePath -> IO P.PackageName+guessPackageName = liftM (P.PackageName . repair . last . splitDirectories)+                 . tryCanonicalizePath+  where+    -- Treat each span of non-alphanumeric characters as a hyphen. Each+    -- hyphenated component of a package name must contain at least one+    -- alphabetic character. An arbitrary character ('x') will be prepended if+    -- this is not the case for the first component, and subsequent components+    -- will simply be run together. For example, "1+2_foo-3" will become+    -- "x12-foo3".+    repair = repair' ('x' :) id+    repair' invalid valid x = case dropWhile (not . isAlphaNum) x of+        "" -> repairComponent ""+        x' -> let (c, r) = first repairComponent $ break (not . isAlphaNum) x'+              in c ++ repairRest r+      where+        repairComponent c | all isNumber c = invalid c+                          | otherwise      = valid c+    repairRest = repair' id ('-' :)+ -- |Data type of source files found in the working directory data SourceFileEntry = SourceFileEntry     { relativeSourcePath :: FilePath@@ -67,7 +118,7 @@   = projectRoot </> relPath </> toFilePath m <.> ext  -- |Search for source files in the given directory--- and return pairs of guessed haskell source path and+-- and return pairs of guessed Haskell source path and -- module names. scanForModules :: FilePath -> IO [SourceFileEntry] scanForModules rootDir = scanForModulesIn rootDir rootDir@@ -232,18 +283,18 @@ darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL"  gitEnv :: Enviro -> AuthorGuess-gitEnv env = (name, email)+gitEnv env = (name, mail)   where-    name  = maybeFlag "GIT_AUTHOR_NAME" env-    email = maybeFlag "GIT_AUTHOR_EMAIL" env+    name = maybeFlag "GIT_AUTHOR_NAME" env+    mail = maybeFlag "GIT_AUTHOR_EMAIL" env  darcsCfg :: Maybe String -> AuthorGuess darcsCfg = maybe mempty nameAndMail  emailEnv :: Enviro -> AuthorGuess-emailEnv env = (mempty, email)+emailEnv env = (mempty, mail)   where-    email = maybeFlag "EMAIL" env+    mail = maybeFlag "EMAIL" env  gitCfg :: GitLoc -> IO AuthorGuess gitCfg which = do@@ -278,7 +329,7 @@         then fmap Just $ readFile f         else return Nothing --- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached+-- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached knownCategories :: SourcePackageDb -> [String] knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet     [ cat | pkg <- map head (allPackagesByName sourcePkgIndex)@@ -291,17 +342,17 @@ nameAndMail str   | all isSpace nameOrEmail = mempty   | null erest = (mempty, Flag $ trim nameOrEmail)-  | otherwise  = (Flag $ trim nameOrEmail, Flag email)+  | otherwise  = (Flag $ trim nameOrEmail, Flag mail)   where     (nameOrEmail,erest) = break (== '<') str-    (email,_)           = break (== '>') (tail erest)+    (mail,_)            = break (== '>') (tail erest)  trim :: String -> String trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse   where     removeLeadingSpace  = dropWhile isSpace --- split string at given character, and remove whitespaces+-- split string at given character, and remove whitespace splitString :: Char -> String -> [String] splitString sep str = go str where     go s = if null s' then [] else tok : go rest where

Distribution/Client/Init/Licenses.hs view

@@ -1,17 +1,50 @@ module Distribution.Client.Init.Licenses   ( License+  , bsd2   , bsd3   , gplv2   , gplv3-  , lgpl2+  , lgpl21   , lgpl3   , agplv3   , apache20+  , mit+  , mpl20    ) where  type License = String +bsd2 :: String -> String -> License+bsd2 authors year = unlines+    [ "Copyright (c) " ++ year ++ ", " ++ authors+    , "All rights reserved."+    , ""+    , "Redistribution and use in source and binary forms, with or without"+    , "modification, are permitted provided that the following conditions are"+    , "met:"+    , ""+    , "1. Redistributions of source code must retain the above copyright"+    , "   notice, this list of conditions and the following disclaimer."+    , ""+    , "2. Redistributions in binary form must reproduce the above copyright"+    , "   notice, this list of conditions and the following disclaimer in the"+    , "   documentation and/or other materials provided with the"+    , "   distribution."+    , ""+    , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS"+    , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT"+    , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR"+    , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT"+    , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,"+    , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT"+    , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,"+    , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY"+    , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT"+    , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE"+    , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."+    ]+ bsd3 :: String -> String -> License bsd3 authors year = unlines     [ "Copyright (c) " ++ year ++ ", " ++ authors@@ -469,7 +502,7 @@     , ""     , "  \"Copyright\" also means copyright-like laws that apply to other kinds of"     , "works, such as semiconductor masks."-    , " "+    , ""     , "  \"The Program\" refers to any copyrightable work licensed under this"     , "License.  Each licensee is addressed as \"you\".  \"Licensees\" and"     , "\"recipients\" may be individuals or organizations."@@ -902,7 +935,7 @@     , "covered work in a country, or your recipient's use of the covered work"     , "in a country, would infringe one or more identifiable patents in that"     , "country that you have reason to believe are valid."-    , "  "+    , ""     , "  If, pursuant to or in connection with a single transaction or"     , "arrangement, you convey, or propagate by procuring conveyance of, a"     , "covered work, and grant a patent license to some of the parties"@@ -1065,7 +1098,6 @@     , "the library.  If this is what you want to do, use the GNU Lesser General"     , "Public License instead of this License.  But first, please read"     , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."-    , ""     ]  agplv3 :: License@@ -1733,117 +1765,130 @@     , "<http://www.gnu.org/licenses/>."     ] -lgpl2 :: License-lgpl2 = unlines-    [ "           GNU LIBRARY GENERAL PUBLIC LICENSE"-    , "                 Version 2, June 1991"+lgpl21 :: License+lgpl21 = unlines+    [ "                  GNU LESSER GENERAL PUBLIC LICENSE"+    , "                       Version 2.1, February 1999"     , ""-    , " Copyright (C) 1991 Free Software Foundation, Inc."+    , " Copyright (C) 1991, 1999 Free Software Foundation, Inc."     , " 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"     , " Everyone is permitted to copy and distribute verbatim copies"     , " of this license document, but changing it is not allowed."     , ""-    , "[This is the first released version of the library GPL.  It is"-    , " numbered 2 because it goes with version 2 of the ordinary GPL.]"+    , "[This is the first released version of the Lesser GPL.  It also counts"+    , " as the successor of the GNU Library Public License, version 2, hence"+    , " the version number 2.1.]"     , ""-    , "                     Preamble"+    , "                            Preamble"     , ""     , "  The licenses for most software are designed to take away your"     , "freedom to share and change it.  By contrast, the GNU General Public"     , "Licenses are intended to guarantee your freedom to share and change"     , "free software--to make sure the software is free for all its users."     , ""-    , "  This license, the Library General Public License, applies to some"-    , "specially designated Free Software Foundation software, and to any"-    , "other libraries whose authors decide to use it.  You can use it for"-    , "your libraries, too."+    , "  This license, the Lesser General Public License, applies to some"+    , "specially designated software packages--typically libraries--of the"+    , "Free Software Foundation and other authors who decide to use it.  You"+    , "can use it too, but we suggest you first think carefully about whether"+    , "this license or the ordinary General Public License is the better"+    , "strategy to use in any particular case, based on the explanations below."     , ""-    , "  When we speak of free software, we are referring to freedom, not"-    , "price.  Our General Public Licenses are designed to make sure that you"-    , "have the freedom to distribute copies of free software (and charge for"-    , "this service if you wish), that you receive source code or can get it"-    , "if you want it, that you can change the software or use pieces of it"-    , "in new free programs; and that you know you can do these things."+    , "  When we speak of free software, we are referring to freedom of use,"+    , "not price.  Our General Public Licenses are designed to make sure that"+    , "you have the freedom to distribute copies of free software (and charge"+    , "for this service if you wish); that you receive source code or can get"+    , "it if you want it; that you can change the software and use pieces of"+    , "it in new free programs; and that you are informed that you can do"+    , "these things."     , ""     , "  To protect your rights, we need to make restrictions that forbid"-    , "anyone to deny you these rights or to ask you to surrender the rights."-    , "These restrictions translate to certain responsibilities for you if"-    , "you distribute copies of the library, or if you modify it."+    , "distributors to deny you these rights or to ask you to surrender these"+    , "rights.  These restrictions translate to certain responsibilities for"+    , "you if you distribute copies of the library or if you modify it."     , ""     , "  For example, if you distribute copies of the library, whether gratis"     , "or for a fee, you must give the recipients all the rights that we gave"     , "you.  You must make sure that they, too, receive or can get the source"-    , "code.  If you link a program with the library, you must provide"-    , "complete object files to the recipients so that they can relink them"-    , "with the library, after making changes to the library and recompiling"+    , "code.  If you link other code with the library, you must provide"+    , "complete object files to the recipients, so that they can relink them"+    , "with the library after making changes to the library and recompiling"     , "it.  And you must show them these terms so they know their rights."     , ""-    , "  Our method of protecting your rights has two steps: (1) copyright"-    , "the library, and (2) offer you this license which gives you legal"+    , "  We protect your rights with a two-step method: (1) we copyright the"+    , "library, and (2) we offer you this license, which gives you legal"     , "permission to copy, distribute and/or modify the library."     , ""-    , "  Also, for each distributor's protection, we want to make certain"-    , "that everyone understands that there is no warranty for this free"-    , "library.  If the library is modified by someone else and passed on, we"-    , "want its recipients to know that what they have is not the original"-    , "version, so that any problems introduced by others will not reflect on"-    , "the original authors' reputations."+    , "  To protect each distributor, we want to make it very clear that"+    , "there is no warranty for the free library.  Also, if the library is"+    , "modified by someone else and passed on, the recipients should know"+    , "that what they have is not the original version, so that the original"+    , "author's reputation will not be affected by problems that might be"+    , "introduced by others."     , ""-    , "  Finally, any free program is threatened constantly by software"-    , "patents.  We wish to avoid the danger that companies distributing free"-    , "software will individually obtain patent licenses, thus in effect"-    , "transforming the program into proprietary software.  To prevent this,"-    , "we have made it clear that any patent must be licensed for everyone's"-    , "free use or not licensed at all."+    , "  Finally, software patents pose a constant threat to the existence of"+    , "any free program.  We wish to make sure that a company cannot"+    , "effectively restrict the users of a free program by obtaining a"+    , "restrictive license from a patent holder.  Therefore, we insist that"+    , "any patent license obtained for a version of the library must be"+    , "consistent with the full freedom of use specified in this license."     , ""-    , "  Most GNU software, including some libraries, is covered by the ordinary"-    , "GNU General Public License, which was designed for utility programs.  This"-    , "license, the GNU Library General Public License, applies to certain"-    , "designated libraries.  This license is quite different from the ordinary"-    , "one; be sure to read it in full, and don't assume that anything in it is"-    , "the same as in the ordinary license."+    , "  Most GNU software, including some libraries, is covered by the"+    , "ordinary GNU General Public License.  This license, the GNU Lesser"+    , "General Public License, applies to certain designated libraries, and"+    , "is quite different from the ordinary General Public License.  We use"+    , "this license for certain libraries in order to permit linking those"+    , "libraries into non-free programs."     , ""-    , "  The reason we have a separate public license for some libraries is that"-    , "they blur the distinction we usually make between modifying or adding to a"-    , "program and simply using it.  Linking a program with a library, without"-    , "changing the library, is in some sense simply using the library, and is"-    , "analogous to running a utility program or application program.  However, in"-    , "a textual and legal sense, the linked executable is a combined work, a"-    , "derivative of the original library, and the ordinary General Public License"-    , "treats it as such."+    , "  When a program is linked with a library, whether statically or using"+    , "a shared library, the combination of the two is legally speaking a"+    , "combined work, a derivative of the original library.  The ordinary"+    , "General Public License therefore permits such linking only if the"+    , "entire combination fits its criteria of freedom.  The Lesser General"+    , "Public License permits more lax criteria for linking other code with"+    , "the library."     , ""-    , "  Because of this blurred distinction, using the ordinary General"-    , "Public License for libraries did not effectively promote software"-    , "sharing, because most developers did not use the libraries.  We"-    , "concluded that weaker conditions might promote sharing better."+    , "  We call this license the \"Lesser\" General Public License because it"+    , "does Less to protect the user's freedom than the ordinary General"+    , "Public License.  It also provides other free software developers Less"+    , "of an advantage over competing non-free programs.  These disadvantages"+    , "are the reason we use the ordinary General Public License for many"+    , "libraries.  However, the Lesser license provides advantages in certain"+    , "special circumstances."     , ""-    , "  However, unrestricted linking of non-free programs would deprive the"-    , "users of those programs of all benefit from the free status of the"-    , "libraries themselves.  This Library General Public License is intended to"-    , "permit developers of non-free programs to use free libraries, while"-    , "preserving your freedom as a user of such programs to change the free"-    , "libraries that are incorporated in them.  (We have not seen how to achieve"-    , "this as regards changes in header files, but we have achieved it as regards"-    , "changes in the actual functions of the Library.)  The hope is that this"-    , "will lead to faster development of free libraries."+    , "  For example, on rare occasions, there may be a special need to"+    , "encourage the widest possible use of a certain library, so that it becomes"+    , "a de-facto standard.  To achieve this, non-free programs must be"+    , "allowed to use the library.  A more frequent case is that a free"+    , "library does the same job as widely used non-free libraries.  In this"+    , "case, there is little to gain by limiting the free library to free"+    , "software only, so we use the Lesser General Public License."     , ""+    , "  In other cases, permission to use a particular library in non-free"+    , "programs enables a greater number of people to use a large body of"+    , "free software.  For example, permission to use the GNU C Library in"+    , "non-free programs enables many more people to use the whole GNU"+    , "operating system, as well as its variant, the GNU/Linux operating"+    , "system."+    , ""+    , "  Although the Lesser General Public License is Less protective of the"+    , "users' freedom, it does ensure that the user of a program that is"+    , "linked with the Library has the freedom and the wherewithal to run"+    , "that program using a modified version of the Library."+    , ""     , "  The precise terms and conditions for copying, distribution and"     , "modification follow.  Pay close attention to the difference between a"     , "\"work based on the library\" and a \"work that uses the library\".  The"-    , "former contains code derived from the library, while the latter only"-    , "works together with the library."-    , ""-    , "  Note that it is possible for a library to be covered by the ordinary"-    , "General Public License rather than by this special one."+    , "former contains code derived from the library, whereas the latter must"+    , "be combined with the library in order to run."     , ""-    , "              GNU LIBRARY GENERAL PUBLIC LICENSE"+    , "                  GNU LESSER GENERAL PUBLIC LICENSE"     , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"     , ""-    , "  0. This License Agreement applies to any software library which"-    , "contains a notice placed by the copyright holder or other authorized"-    , "party saying it may be distributed under the terms of this Library"-    , "General Public License (also called \"this License\").  Each licensee is"-    , "addressed as \"you\"."+    , "  0. This License Agreement applies to any software library or other"+    , "program which contains a notice placed by the copyright holder or"+    , "other authorized party saying it may be distributed under the terms of"+    , "this Lesser General Public License (also called \"this License\")."+    , "Each licensee is addressed as \"you\"."     , ""     , "  A \"library\" means a collection of software functions and/or data"     , "prepared so as to be conveniently linked with application programs"@@ -1870,7 +1915,7 @@     , "on the Library (independent of the use of the Library in a tool for"     , "writing it).  Whether that is true depends on what the Library does"     , "and what the program that uses the Library does."-    , "  "+    , ""     , "  1. You may copy and distribute verbatim copies of the Library's"     , "complete source code as you receive it, in any medium, provided that"     , "you conspicuously and appropriately publish on each copy an"@@ -1992,7 +2037,7 @@     , "Any executables containing that work also fall under Section 6,"     , "whether or not they are linked directly with the Library itself."     , ""-    , "  6. As an exception to the Sections above, you may also compile or"+    , "  6. As an exception to the Sections above, you may also combine or"     , "link a \"work that uses the Library\" with the Library to produce a"     , "work containing portions of the Library, and distribute that work"     , "under terms of your choice, provided that the terms permit"@@ -2019,23 +2064,31 @@     , "    Library will not necessarily be able to recompile the application"     , "    to use the modified definitions.)"     , ""-    , "    b) Accompany the work with a written offer, valid for at"+    , "    b) Use a suitable shared library mechanism for linking with the"+    , "    Library.  A suitable mechanism is one that (1) uses at run time a"+    , "    copy of the library already present on the user's computer system,"+    , "    rather than copying library functions into the executable, and (2)"+    , "    will operate properly with a modified version of the library, if"+    , "    the user installs one, as long as the modified version is"+    , "    interface-compatible with the version that the work was made with."+    , ""+    , "    c) Accompany the work with a written offer, valid for at"     , "    least three years, to give the same user the materials"     , "    specified in Subsection 6a, above, for a charge no more"     , "    than the cost of performing this distribution."     , ""-    , "    c) If distribution of the work is made by offering access to copy"+    , "    d) If distribution of the work is made by offering access to copy"     , "    from a designated place, offer equivalent access to copy the above"     , "    specified materials from the same place."     , ""-    , "    d) Verify that the user has already received a copy of these"+    , "    e) Verify that the user has already received a copy of these"     , "    materials or that you have already sent this user a copy."     , ""     , "  For an executable, the required form of the \"work that uses the"     , "Library\" must include any data and utility programs needed for"     , "reproducing the executable from it.  However, as a special exception,"-    , "the source code distributed need not include anything that is normally"-    , "distributed (in either source or binary form) with the major"+    , "the materials to be distributed need not include anything that is"+    , "normally distributed (in either source or binary form) with the major"     , "components (compiler, kernel, and so on) of the operating system on"     , "which the executable runs, unless that component itself accompanies"     , "the executable."@@ -2084,7 +2137,7 @@     , "original licensor to copy, distribute, link with or modify the Library"     , "subject to these terms and conditions.  You may not impose any further"     , "restrictions on the recipients' exercise of the rights granted herein."-    , "You are not responsible for enforcing compliance by third parties to"+    , "You are not responsible for enforcing compliance by third parties with"     , "this License."     , ""     , "  11. If, as a consequence of a court judgment or allegation of patent"@@ -2127,7 +2180,7 @@     , "written in the body of this License."     , ""     , "  13. The Free Software Foundation may publish revised and/or new"-    , "versions of the Library General Public License from time to time."+    , "versions of the Lesser General Public License from time to time."     , "Such new versions will be similar in spirit to the present version,"     , "but may differ in detail to address new problems or concerns."     , ""@@ -2148,7 +2201,7 @@     , "of all derivatives of our free software and of promoting the sharing"     , "and reuse of software generally."     , ""-    , "                     NO WARRANTY"+    , "                            NO WARRANTY"     , ""     , "  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO"     , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW."@@ -2171,7 +2224,7 @@     , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH"     , "DAMAGES."     , ""-    , "              END OF TERMS AND CONDITIONS"+    , "                     END OF TERMS AND CONDITIONS"     , ""     , "           How to Apply These Terms to Your New Libraries"     , ""@@ -2190,17 +2243,17 @@     , "    Copyright (C) <year>  <name of author>"     , ""     , "    This library is free software; you can redistribute it and/or"-    , "    modify it under the terms of the GNU Library General Public"+    , "    modify it under the terms of the GNU Lesser General Public"     , "    License as published by the Free Software Foundation; either"-    , "    version 2 of the License, or (at your option) any later version."+    , "    version 2.1 of the License, or (at your option) any later version."     , ""     , "    This library is distributed in the hope that it will be useful,"     , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"     , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU"-    , "    Library General Public License for more details."+    , "    Lesser General Public License for more details."     , ""-    , "    You should have received a copy of the GNU Library General Public"-    , "    License along with this library; if not, write to the Free"+    , "    You should have received a copy of the GNU Lesser General Public"+    , "    License along with this library; if not, write to the Free Software"     , "    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"     , ""     , "Also add information on how to contact you by electronic and paper mail."@@ -2232,7 +2285,7 @@     , "the terms and conditions of version 3 of the GNU General Public"     , "License, supplemented by the additional permissions listed below."     , ""-    , "  0. Additional Definitions. "+    , "  0. Additional Definitions."     , ""     , "  As used herein, \"this License\" refers to version 3 of the GNU Lesser"     , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU"@@ -2333,7 +2386,7 @@     , "       a copy of the Library already present on the user's computer"     , "       system, and (b) will operate properly with a modified version"     , "       of the Library that is interface-compatible with the Linked"-    , "       Version. "+    , "       Version."     , ""     , "   e) Provide Installation Information, but only if you would otherwise"     , "   be required to provide such information under section 6 of the"@@ -2591,4 +2644,405 @@     , "   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied."     , "   See the License for the specific language governing permissions and"     , "   limitations under the License."+    ]++mit :: String -> String -> License+mit authors year = unlines+    [ "Copyright (c) " ++ year ++ " " ++ authors+    , ""+    , "Permission is hereby granted, free of charge, to any person obtaining"+    , "a copy of this software and associated documentation files (the"+    , "\"Software\"), to deal in the Software without restriction, including"+    , "without limitation the rights to use, copy, modify, merge, publish,"+    , "distribute, sublicense, and/or sell copies of the Software, and to"+    , "permit persons to whom the Software is furnished to do so, subject to"+    , "the following conditions:"+    , ""+    , "The above copyright notice and this permission notice shall be included"+    , "in all copies or substantial portions of the Software."+    , ""+    , "THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,"+    , "EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF"+    , "MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT."+    , "IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY"+    , "CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,"+    , "TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE"+    , "SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE."+    ]++mpl20 :: License+mpl20 = unlines+    [ "Mozilla Public License Version 2.0"+    , "=================================="+    , ""+    , "1. Definitions"+    , "--------------"+    , ""+    , "1.1. \"Contributor\""+    , "    means each individual or legal entity that creates, contributes to"+    , "    the creation of, or owns Covered Software."+    , ""+    , "1.2. \"Contributor Version\""+    , "    means the combination of the Contributions of others (if any) used"+    , "    by a Contributor and that particular Contributor's Contribution."+    , ""+    , "1.3. \"Contribution\""+    , "    means Covered Software of a particular Contributor."+    , ""+    , "1.4. \"Covered Software\""+    , "    means Source Code Form to which the initial Contributor has attached"+    , "    the notice in Exhibit A, the Executable Form of such Source Code"+    , "    Form, and Modifications of such Source Code Form, in each case"+    , "    including portions thereof."+    , ""+    , "1.5. \"Incompatible With Secondary Licenses\""+    , "    means"+    , ""+    , "    (a) that the initial Contributor has attached the notice described"+    , "        in Exhibit B to the Covered Software; or"+    , ""+    , "    (b) that the Covered Software was made available under the terms of"+    , "        version 1.1 or earlier of the License, but not also under the"+    , "        terms of a Secondary License."+    , ""+    , "1.6. \"Executable Form\""+    , "    means any form of the work other than Source Code Form."+    , ""+    , "1.7. \"Larger Work\""+    , "    means a work that combines Covered Software with other material, in"+    , "    a separate file or files, that is not Covered Software."+    , ""+    , "1.8. \"License\""+    , "    means this document."+    , ""+    , "1.9. \"Licensable\""+    , "    means having the right to grant, to the maximum extent possible,"+    , "    whether at the time of the initial grant or subsequently, any and"+    , "    all of the rights conveyed by this License."+    , ""+    , "1.10. \"Modifications\""+    , "    means any of the following:"+    , ""+    , "    (a) any file in Source Code Form that results from an addition to,"+    , "        deletion from, or modification of the contents of Covered"+    , "        Software; or"+    , ""+    , "    (b) any new file in Source Code Form that contains any Covered"+    , "        Software."+    , ""+    , "1.11. \"Patent Claims\" of a Contributor"+    , "    means any patent claim(s), including without limitation, method,"+    , "    process, and apparatus claims, in any patent Licensable by such"+    , "    Contributor that would be infringed, but for the grant of the"+    , "    License, by the making, using, selling, offering for sale, having"+    , "    made, import, or transfer of either its Contributions or its"+    , "    Contributor Version."+    , ""+    , "1.12. \"Secondary License\""+    , "    means either the GNU General Public License, Version 2.0, the GNU"+    , "    Lesser General Public License, Version 2.1, the GNU Affero General"+    , "    Public License, Version 3.0, or any later versions of those"+    , "    licenses."+    , ""+    , "1.13. \"Source Code Form\""+    , "    means the form of the work preferred for making modifications."+    , ""+    , "1.14. \"You\" (or \"Your\")"+    , "    means an individual or a legal entity exercising rights under this"+    , "    License. For legal entities, \"You\" includes any entity that"+    , "    controls, is controlled by, or is under common control with You. For"+    , "    purposes of this definition, \"control\" means (a) the power, direct"+    , "    or indirect, to cause the direction or management of such entity,"+    , "    whether by contract or otherwise, or (b) ownership of more than"+    , "    fifty percent (50%) of the outstanding shares or beneficial"+    , "    ownership of such entity."+    , ""+    , "2. License Grants and Conditions"+    , "--------------------------------"+    , ""+    , "2.1. Grants"+    , ""+    , "Each Contributor hereby grants You a world-wide, royalty-free,"+    , "non-exclusive license:"+    , ""+    , "(a) under intellectual property rights (other than patent or trademark)"+    , "    Licensable by such Contributor to use, reproduce, make available,"+    , "    modify, display, perform, distribute, and otherwise exploit its"+    , "    Contributions, either on an unmodified basis, with Modifications, or"+    , "    as part of a Larger Work; and"+    , ""+    , "(b) under Patent Claims of such Contributor to make, use, sell, offer"+    , "    for sale, have made, import, and otherwise transfer either its"+    , "    Contributions or its Contributor Version."+    , ""+    , "2.2. Effective Date"+    , ""+    , "The licenses granted in Section 2.1 with respect to any Contribution"+    , "become effective for each Contribution on the date the Contributor first"+    , "distributes such Contribution."+    , ""+    , "2.3. Limitations on Grant Scope"+    , ""+    , "The licenses granted in this Section 2 are the only rights granted under"+    , "this License. No additional rights or licenses will be implied from the"+    , "distribution or licensing of Covered Software under this License."+    , "Notwithstanding Section 2.1(b) above, no patent license is granted by a"+    , "Contributor:"+    , ""+    , "(a) for any code that a Contributor has removed from Covered Software;"+    , "    or"+    , ""+    , "(b) for infringements caused by: (i) Your and any other third party's"+    , "    modifications of Covered Software, or (ii) the combination of its"+    , "    Contributions with other software (except as part of its Contributor"+    , "    Version); or"+    , ""+    , "(c) under Patent Claims infringed by Covered Software in the absence of"+    , "    its Contributions."+    , ""+    , "This License does not grant any rights in the trademarks, service marks,"+    , "or logos of any Contributor (except as may be necessary to comply with"+    , "the notice requirements in Section 3.4)."+    , ""+    , "2.4. Subsequent Licenses"+    , ""+    , "No Contributor makes additional grants as a result of Your choice to"+    , "distribute the Covered Software under a subsequent version of this"+    , "License (see Section 10.2) or under the terms of a Secondary License (if"+    , "permitted under the terms of Section 3.3)."+    , ""+    , "2.5. Representation"+    , ""+    , "Each Contributor represents that the Contributor believes its"+    , "Contributions are its original creation(s) or it has sufficient rights"+    , "to grant the rights to its Contributions conveyed by this License."+    , ""+    , "2.6. Fair Use"+    , ""+    , "This License is not intended to limit any rights You have under"+    , "applicable copyright doctrines of fair use, fair dealing, or other"+    , "equivalents."+    , ""+    , "2.7. Conditions"+    , ""+    , "Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted"+    , "in Section 2.1."+    , ""+    , "3. Responsibilities"+    , "-------------------"+    , ""+    , "3.1. Distribution of Source Form"+    , ""+    , "All distribution of Covered Software in Source Code Form, including any"+    , "Modifications that You create or to which You contribute, must be under"+    , "the terms of this License. You must inform recipients that the Source"+    , "Code Form of the Covered Software is governed by the terms of this"+    , "License, and how they can obtain a copy of this License. You may not"+    , "attempt to alter or restrict the recipients' rights in the Source Code"+    , "Form."+    , ""+    , "3.2. Distribution of Executable Form"+    , ""+    , "If You distribute Covered Software in Executable Form then:"+    , ""+    , "(a) such Covered Software must also be made available in Source Code"+    , "    Form, as described in Section 3.1, and You must inform recipients of"+    , "    the Executable Form how they can obtain a copy of such Source Code"+    , "    Form by reasonable means in a timely manner, at a charge no more"+    , "    than the cost of distribution to the recipient; and"+    , ""+    , "(b) You may distribute such Executable Form under the terms of this"+    , "    License, or sublicense it under different terms, provided that the"+    , "    license for the Executable Form does not attempt to limit or alter"+    , "    the recipients' rights in the Source Code Form under this License."+    , ""+    , "3.3. Distribution of a Larger Work"+    , ""+    , "You may create and distribute a Larger Work under terms of Your choice,"+    , "provided that You also comply with the requirements of this License for"+    , "the Covered Software. If the Larger Work is a combination of Covered"+    , "Software with a work governed by one or more Secondary Licenses, and the"+    , "Covered Software is not Incompatible With Secondary Licenses, this"+    , "License permits You to additionally distribute such Covered Software"+    , "under the terms of such Secondary License(s), so that the recipient of"+    , "the Larger Work may, at their option, further distribute the Covered"+    , "Software under the terms of either this License or such Secondary"+    , "License(s)."+    , ""+    , "3.4. Notices"+    , ""+    , "You may not remove or alter the substance of any license notices"+    , "(including copyright notices, patent notices, disclaimers of warranty,"+    , "or limitations of liability) contained within the Source Code Form of"+    , "the Covered Software, except that You may alter any license notices to"+    , "the extent required to remedy known factual inaccuracies."+    , ""+    , "3.5. Application of Additional Terms"+    , ""+    , "You may choose to offer, and to charge a fee for, warranty, support,"+    , "indemnity or liability obligations to one or more recipients of Covered"+    , "Software. However, You may do so only on Your own behalf, and not on"+    , "behalf of any Contributor. You must make it absolutely clear that any"+    , "such warranty, support, indemnity, or liability obligation is offered by"+    , "You alone, and You hereby agree to indemnify every Contributor for any"+    , "liability incurred by such Contributor as a result of warranty, support,"+    , "indemnity or liability terms You offer. You may include additional"+    , "disclaimers of warranty and limitations of liability specific to any"+    , "jurisdiction."+    , ""+    , "4. Inability to Comply Due to Statute or Regulation"+    , "---------------------------------------------------"+    , ""+    , "If it is impossible for You to comply with any of the terms of this"+    , "License with respect to some or all of the Covered Software due to"+    , "statute, judicial order, or regulation then You must: (a) comply with"+    , "the terms of this License to the maximum extent possible; and (b)"+    , "describe the limitations and the code they affect. Such description must"+    , "be placed in a text file included with all distributions of the Covered"+    , "Software under this License. Except to the extent prohibited by statute"+    , "or regulation, such description must be sufficiently detailed for a"+    , "recipient of ordinary skill to be able to understand it."+    , ""+    , "5. Termination"+    , "--------------"+    , ""+    , "5.1. The rights granted under this License will terminate automatically"+    , "if You fail to comply with any of its terms. However, if You become"+    , "compliant, then the rights granted under this License from a particular"+    , "Contributor are reinstated (a) provisionally, unless and until such"+    , "Contributor explicitly and finally terminates Your grants, and (b) on an"+    , "ongoing basis, if such Contributor fails to notify You of the"+    , "non-compliance by some reasonable means prior to 60 days after You have"+    , "come back into compliance. Moreover, Your grants from a particular"+    , "Contributor are reinstated on an ongoing basis if such Contributor"+    , "notifies You of the non-compliance by some reasonable means, this is the"+    , "first time You have received notice of non-compliance with this License"+    , "from such Contributor, and You become compliant prior to 30 days after"+    , "Your receipt of the notice."+    , ""+    , "5.2. If You initiate litigation against any entity by asserting a patent"+    , "infringement claim (excluding declaratory judgment actions,"+    , "counter-claims, and cross-claims) alleging that a Contributor Version"+    , "directly or indirectly infringes any patent, then the rights granted to"+    , "You by any and all Contributors for the Covered Software under Section"+    , "2.1 of this License shall terminate."+    , ""+    , "5.3. In the event of termination under Sections 5.1 or 5.2 above, all"+    , "end user license agreements (excluding distributors and resellers) which"+    , "have been validly granted by You or Your distributors under this License"+    , "prior to termination shall survive termination."+    , ""+    , "************************************************************************"+    , "*                                                                      *"+    , "*  6. Disclaimer of Warranty                                           *"+    , "*  -------------------------                                           *"+    , "*                                                                      *"+    , "*  Covered Software is provided under this License on an \"as is\"       *"+    , "*  basis, without warranty of any kind, either expressed, implied, or  *"+    , "*  statutory, including, without limitation, warranties that the       *"+    , "*  Covered Software is free of defects, merchantable, fit for a        *"+    , "*  particular purpose or non-infringing. The entire risk as to the     *"+    , "*  quality and performance of the Covered Software is with You.        *"+    , "*  Should any Covered Software prove defective in any respect, You     *"+    , "*  (not any Contributor) assume the cost of any necessary servicing,   *"+    , "*  repair, or correction. This disclaimer of warranty constitutes an   *"+    , "*  essential part of this License. No use of any Covered Software is   *"+    , "*  authorized under this License except under this disclaimer.         *"+    , "*                                                                      *"+    , "************************************************************************"+    , ""+    , "************************************************************************"+    , "*                                                                      *"+    , "*  7. Limitation of Liability                                          *"+    , "*  --------------------------                                          *"+    , "*                                                                      *"+    , "*  Under no circumstances and under no legal theory, whether tort      *"+    , "*  (including negligence), contract, or otherwise, shall any           *"+    , "*  Contributor, or anyone who distributes Covered Software as          *"+    , "*  permitted above, be liable to You for any direct, indirect,         *"+    , "*  special, incidental, or consequential damages of any character      *"+    , "*  including, without limitation, damages for lost profits, loss of    *"+    , "*  goodwill, work stoppage, computer failure or malfunction, or any    *"+    , "*  and all other commercial damages or losses, even if such party      *"+    , "*  shall have been informed of the possibility of such damages. This   *"+    , "*  limitation of liability shall not apply to liability for death or   *"+    , "*  personal injury resulting from such party's negligence to the       *"+    , "*  extent applicable law prohibits such limitation. Some               *"+    , "*  jurisdictions do not allow the exclusion or limitation of           *"+    , "*  incidental or consequential damages, so this exclusion and          *"+    , "*  limitation may not apply to You.                                    *"+    , "*                                                                      *"+    , "************************************************************************"+    , ""+    , "8. Litigation"+    , "-------------"+    , ""+    , "Any litigation relating to this License may be brought only in the"+    , "courts of a jurisdiction where the defendant maintains its principal"+    , "place of business and such litigation shall be governed by laws of that"+    , "jurisdiction, without reference to its conflict-of-law provisions."+    , "Nothing in this Section shall prevent a party's ability to bring"+    , "cross-claims or counter-claims."+    , ""+    , "9. Miscellaneous"+    , "----------------"+    , ""+    , "This License represents the complete agreement concerning the subject"+    , "matter hereof. If any provision of this License is held to be"+    , "unenforceable, such provision shall be reformed only to the extent"+    , "necessary to make it enforceable. Any law or regulation which provides"+    , "that the language of a contract shall be construed against the drafter"+    , "shall not be used to construe this License against a Contributor."+    , ""+    , "10. Versions of the License"+    , "---------------------------"+    , ""+    , "10.1. New Versions"+    , ""+    , "Mozilla Foundation is the license steward. Except as provided in Section"+    , "10.3, no one other than the license steward has the right to modify or"+    , "publish new versions of this License. Each version will be given a"+    , "distinguishing version number."+    , ""+    , "10.2. Effect of New Versions"+    , ""+    , "You may distribute the Covered Software under the terms of the version"+    , "of the License under which You originally received the Covered Software,"+    , "or under the terms of any subsequent version published by the license"+    , "steward."+    , ""+    , "10.3. Modified Versions"+    , ""+    , "If you create software not governed by this License, and you want to"+    , "create a new license for such software, you may create and use a"+    , "modified version of this License if you rename the license and remove"+    , "any references to the name of the license steward (except to note that"+    , "such modified license differs from this License)."+    , ""+    , "10.4. Distributing Source Code Form that is Incompatible With Secondary"+    , "Licenses"+    , ""+    , "If You choose to distribute Source Code Form that is Incompatible With"+    , "Secondary Licenses under the terms of this version of the License, the"+    , "notice described in Exhibit B of this License must be attached."+    , ""+    , "Exhibit A - Source Code Form License Notice"+    , "-------------------------------------------"+    , ""+    , "  This Source Code Form is subject to the terms of the Mozilla Public"+    , "  License, v. 2.0. If a copy of the MPL was not distributed with this"+    , "  file, You can obtain one at http://mozilla.org/MPL/2.0/."+    , ""+    , "If it is not possible or desirable to put the notice in a particular"+    , "file, then You may include the notice in a location (such as a LICENSE"+    , "file in a relevant directory) where a recipient would be likely to look"+    , "for such a notice."+    , ""+    , "You may add additional accurate notices of copyright ownership."+    , ""+    , "Exhibit B - \"Incompatible With Secondary Licenses\" Notice"+    , "---------------------------------------------------------"+    , ""+    , "  This Source Code Form is \"Incompatible With Secondary Licenses\", as"+    , "  defined by the Mozilla Public License, v. 2.0."     ]

Distribution/Client/Init/Types.hs view

@@ -41,7 +41,7 @@               , noComments     :: Flag Bool               , minimal        :: Flag Bool -              , packageName  :: Flag String+              , packageName  :: Flag P.PackageName               , version      :: Flag Version               , cabalVersion :: Flag VersionRange               , license      :: Flag License@@ -54,6 +54,7 @@               , extraSrc     :: Maybe [String]                , packageType  :: Flag PackageType+              , mainIs       :: Flag FilePath               , language     :: Flag Language                , exposedModules :: Maybe [ModuleName]@@ -98,6 +99,7 @@     , category       = mempty     , extraSrc       = mempty     , packageType    = mempty+    , mainIs         = mempty     , language       = mempty     , exposedModules = mempty     , otherModules   = mempty@@ -125,6 +127,7 @@     , category       = combine category     , extraSrc       = combine extraSrc     , packageType    = combine packageType+    , mainIs         = combine mainIs     , language       = combine language     , exposedModules = combine exposedModules     , otherModules   = combine otherModules

Distribution/Client/Install.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Install@@ -33,24 +34,31 @@ import Data.Maybe          ( isJust, fromMaybe, maybeToList ) import Control.Exception as Exception-         ( Exception(toException), bracket, catches, Handler(Handler), handleJust-         , IOException, SomeException )+         ( Exception(toException), bracket, catches+         , Handler(Handler), handleJust, IOException, SomeException )+#ifndef mingw32_HOST_OS+import Control.Exception as Exception+         ( Exception(fromException) )+#endif import System.Exit-         ( ExitCode )+         ( ExitCode(..) ) import Distribution.Compat.Exception          ( catchIO, catchExit ) import Control.Monad          ( when, unless ) import System.Directory-         ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing )+         ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,+           createDirectoryIfMissing, removeFile, renameDirectory ) import System.FilePath          ( (</>), (<.>), takeDirectory ) import System.IO-         ( openFile, IOMode(WriteMode), hClose )+         ( openFile, IOMode(AppendMode), hClose ) import System.IO.Error          ( isDoesNotExistError, ioeGetFileName )  import Distribution.Client.Targets+import Distribution.Client.Configure+         ( chooseCabalVersion ) import Distribution.Client.Dependency import Distribution.Client.Dependency.Types          ( Solver(..) )@@ -86,7 +94,7 @@ import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed-import Paths_cabal_install (getBinDir)+import Distribution.Client.Compat.ExecutablePath import Distribution.Client.JobControl  import Distribution.Simple.Compiler@@ -100,12 +108,15 @@ import Distribution.Simple.Setup          ( haddockCommand, HaddockFlags(..)          , buildCommand, BuildFlags(..), emptyBuildFlags-         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe )+         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal-         ( installCommand, InstallFlags(..), TestFlags(..), emptyInstallFlags-         , emptyTestFlags, testCommand, Flag(..) )+         ( Flag(..)+         , copyCommand, CopyFlags(..), emptyCopyFlags+         , registerCommand, RegisterFlags(..), emptyRegisterFlags+         , testCommand, TestFlags(..), emptyTestFlags ) import Distribution.Simple.Utils-         ( rawSystemExit, comparing, writeFileAtomic )+         ( createDirectoryIfMissingVerbose, rawSystemExit, comparing+         , writeFileAtomic, withTempFile , withFileContents ) import Distribution.Simple.InstallDirs as InstallDirs          ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate          , initialPathTemplateEnv, installDirsTemplateEnv )@@ -119,12 +130,15 @@          , FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Configuration          ( finalizePackageDescription )+import Distribution.ParseUtils+         ( showPWarning ) import Distribution.Version-         ( Version, anyVersion, thisVersion )+         ( Version ) import Distribution.Simple.Utils as Utils-         ( notice, info, warn, debugNoWrap, die, intercalate, withTempDirectory )+         ( notice, info, warn, debug, debugNoWrap, die+         , intercalate, withTempDirectory ) import Distribution.Client.Utils-         ( numberOfProcessors, inDir, mergeBy, MergeResult(..)+         ( determineNumJobs, inDir, mergeBy, MergeResult(..)          , tryCanonicalizePath ) import Distribution.System          ( Platform, OS(Windows), buildOS )@@ -187,18 +201,18 @@                                    then installFailedInSandbox else [])     -- TODO: use a better error message, remove duplication.     installFailedInSandbox =-      "\nNote: when using a sandbox, all packages are required to have \-      \consistent dependencies. \-      \Try reinstalling/unregistering the offending packages or \-      \recreating the sandbox."+      "\nNote: when using a sandbox, all packages are required to have "+      ++ "consistent dependencies. "+      ++ "Try reinstalling/unregistering the offending packages or "+      ++ "recreating the sandbox."     logMsg message rest = debugNoWrap verbosity message >> rest --- TODO: Make InstallContext a proper datatype with documented fields.+-- TODO: Make InstallContext a proper data type with documented fields. -- | Common context for makeInstallPlan and processInstallPlan. type InstallContext = ( PackageIndex, SourcePackageDb                       , [UserTarget], [PackageSpecifier SourcePackage] ) --- TODO: Make InstallArgs a proper datatype with documented fields or just get+-- TODO: Make InstallArgs a proper data type with documented fields or just get -- rid of it completely. -- | Initial arguments given to 'install' or 'makeInstallContext'. type InstallArgs = ( PackageDBStack@@ -272,12 +286,13 @@     checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb       installFlags pkgSpecifiers -    unless dryRun $ do+    unless (dryRun || nothingToInstall) $ do       installPlan' <- performInstallations verbosity                       args installedPkgIndex installPlan       postInstallActions verbosity args userTargets installPlan'   where     dryRun = fromFlag (installDryRun installFlags)+    nothingToInstall = null (InstallPlan.ready installPlan)  -- ------------------------------------------------------------ -- * Installation planning@@ -319,11 +334,11 @@        . setShadowPkgs shadowPkgs -      . setStrongFlags strongFlags-       . setPreferenceDefault (if upgradeDeps then PreferAllLatest                                              else PreferLatestForSelected) +      . removeUpperBounds allowNewer+       . addPreferences           -- preferences from the config file or command line           [ PackageVersionPreference name ver@@ -364,10 +379,10 @@     independentGoals = fromFlag (installIndependentGoals installFlags)     avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)     shadowPkgs       = fromFlag (installShadowPkgs       installFlags)-    strongFlags      = fromFlag (installStrongFlags      installFlags)     maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)     upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)     onlyDeps         = fromFlag (installOnlyDeps         installFlags)+    allowNewer       = fromFlag (configAllowNewer        configExFlags)  -- | Remove the provided targets from the install plan. pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan@@ -481,7 +496,7 @@  linearizeInstallPlan :: PackageIndex                      -> InstallPlan-                     -> [(ConfiguredPackage, PackageStatus)]+                     -> [(ReadyPackage, PackageStatus)] linearizeInstallPlan installedPkgIndex plan =     unfoldr next plan   where@@ -492,7 +507,9 @@           pkgid  = packageId pkg           status = packageStatus installedPkgIndex pkg           plan'' = InstallPlan.completed pkgid-                     (BuildOk DocsNotTried TestsNotTried)+                     (BuildOk DocsNotTried TestsNotTried+                              (Just $ Installed.emptyInstalledPackageInfo+                              { Installed.sourcePackageId = pkgid }))                      (InstallPlan.processing [pkg] plan')           --FIXME: This is a bit of a hack,           -- pretending that each package is installed@@ -507,7 +524,7 @@ extractReinstalls (Reinstall ipids _) = ipids extractReinstalls _                   = [] -packageStatus :: PackageIndex -> ConfiguredPackage -> PackageStatus+packageStatus :: PackageIndex -> ReadyPackage -> PackageStatus packageStatus installedPkgIndex cpkg =   case PackageIndex.lookupPackageName installedPkgIndex                                       (packageName cpkg) of@@ -521,7 +538,7 @@   where      changes :: Installed.InstalledPackageInfo-            -> ConfiguredPackage+            -> ReadyPackage             -> [MergeResult PackageIdentifier PackageIdentifier]     changes pkg pkg' =       filter changed@@ -540,7 +557,7 @@  printPlan :: Bool -- is dry run           -> Verbosity-          -> [(ConfiguredPackage, PackageStatus)]+          -> [(ReadyPackage, PackageStatus)]           -> SourcePackageDb           -> IO () printPlan dryRun verbosity plan sourcePkgDb = case plan of@@ -571,10 +588,10 @@                 []   -> ""                 diff -> " changes: "  ++ intercalate ", " (map change diff) -    showLatest :: ConfiguredPackage -> String+    showLatest :: ReadyPackage -> String     showLatest pkg = case mLatestVersion of         Just latestVersion ->-            if pkgVersion /= latestVersion+            if pkgVersion < latestVersion             then (" (latest: " ++ display latestVersion ++ ")")             else ""         Nothing -> ""@@ -590,15 +607,15 @@     toFlagAssignment :: [Flag] -> FlagAssignment     toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) -    nonDefaultFlags :: ConfiguredPackage -> FlagAssignment-    nonDefaultFlags (ConfiguredPackage spkg fa _ _) =+    nonDefaultFlags :: ReadyPackage -> FlagAssignment+    nonDefaultFlags (ReadyPackage spkg fa _ _) =       let defaultAssignment =             toFlagAssignment              (genPackageFlags (Source.packageDescription spkg))       in  fa \\ defaultAssignment -    stanzas :: ConfiguredPackage -> [OptionalStanza]-    stanzas (ConfiguredPackage _ _ sts _) = sts+    stanzas :: ReadyPackage -> [OptionalStanza]+    stanzas (ReadyPackage _ _ sts _) = sts      showStanzas :: [OptionalStanza] -> String     showStanzas = concatMap ((' ' :) . showStanza)@@ -746,7 +763,7 @@         normalUserInstall     = (UserPackageDB `elem` packageDBs)                              && all (not . isSpecificPackageDB) packageDBs -        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True+        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True         installedDocs _                                            = False         isSpecificPackageDB (SpecificPackageDB _) = True         isSpecificPackageDB _                     = False@@ -804,30 +821,41 @@       DependentFailed pkgid -> " depends on " ++ display pkgid                             ++ " which failed to install."       DownloadFailed  e -> " failed while downloading the package."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       UnpackFailed    e -> " failed while unpacking the package."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       ConfigureFailed e -> " failed during the configure step."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       BuildFailed     e -> " failed during the building phase."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       TestsFailed     e -> " failed during the tests phase."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       InstallFailed   e -> " failed during the final install step."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e +    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) =+      "\nThis may be due to an out-of-memory condition."+    onExitFailure _               = ""+#endif++ -- | If we're working inside a sandbox and some add-source deps were installed, -- update the timestamps of those deps. updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo-                        -> Compiler -> Platform -> InstallPlan-                        -> IO ()+                            -> Compiler -> Platform -> InstallPlan+                            -> IO () updateSandboxTimestampsFile (UseSandbox sandboxDir)                             (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))                             comp platform installPlan =   withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do     let allInstalled = [ pkg | InstallPlan.Installed pkg _                             <- InstallPlan.toList installPlan ]-        allSrcPkgs   = [ pkg | ConfiguredPackage pkg _ _ _ <- allInstalled ]+        allSrcPkgs   = [ pkg | ReadyPackage pkg _ _ _ <- allInstalled ]         allPaths     = [ pth | LocalUnpackedPackage pth                             <- map packageSource allSrcPkgs]     allPathsCanonical <- mapM tryCanonicalizePath allPaths@@ -860,22 +888,23 @@    -- With 'install -j' it can be a bit hard to tell whether a sandbox is used.   whenUsingSandbox useSandbox $ \sandboxDir ->-    when parallelBuild $+    when parallelInstall $       notice verbosity $ "Notice: installing into a sandbox located at "                          ++ sandboxDir -  jobControl   <- if parallelBuild then newParallelJobControl-                                   else newSerialJobControl+  jobControl   <- if parallelInstall then newParallelJobControl+                                     else newSerialJobControl   buildLimit   <- newJobLimit numJobs   fetchLimit   <- newJobLimit (min numJobs numFetchJobs)   installLock  <- newLock -- serialise installation   cacheLock    <- newLock -- serialise access to setup exe cache -  executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg ->-    installConfiguredPackage platform compid configFlags-                             cpkg $ \configFlags' src pkg pkgoverride ->+  executeInstallPlan verbosity jobControl useLogFile installPlan $ \rpkg ->+    installReadyPackage platform compid configFlags+                        rpkg $ \configFlags' src pkg pkgoverride ->       fetchSourcePackage verbosity fetchLimit src $ \src' ->-        installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->+        installLocalPackage verbosity buildLimit+                            (packageId pkg) src' distPref $ \mpath ->           installUnpackedPackage verbosity buildLimit installLock numJobs                                  (setupScriptOptions installedPkgIndex cacheLock)                                  miscOptions configFlags' installFlags haddockFlags@@ -885,15 +914,15 @@     platform = InstallPlan.planPlatform installPlan     compid   = InstallPlan.planCompiler installPlan -    numJobs  = case installNumJobs installFlags of-      Cabal.NoFlag        -> 1-      Cabal.Flag Nothing  -> numberOfProcessors-      Cabal.Flag (Just n) -> n-    numFetchJobs  = 2-    parallelBuild = numJobs >= 2+    numJobs         = determineNumJobs (installNumJobs installFlags)+    numFetchJobs    = 2+    parallelInstall = numJobs >= 2+    distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                      (configDistPref configFlags)      setupScriptOptions index lock = SetupScriptOptions {-      useCabalVersion  = maybe anyVersion thisVersion (libVersion miscOptions),+      useCabalVersion  = chooseCabalVersion configExFlags+                         (libVersion miscOptions),       useCompiler      = Just comp,       usePlatform      = Just platform,       -- Hack: we typically want to allow the UserPackageDB for finding the@@ -909,12 +938,10 @@                            then Just index                            else Nothing,       useProgramConfig = conf,-      useDistPref      = fromFlagOrDefault-                           (useDistPref defaultSetupScriptOptions)-                           (configDistPref configFlags),+      useDistPref      = distPref,       useLoggingHandle = Nothing,       useWorkingDir    = Nothing,-      forceExternalSetupMethod = parallelBuild,+      forceExternalSetupMethod = parallelInstall,       setupCacheLock   = Just lock     }     reportingLevel = fromFlag (installBuildReports installFlags)@@ -947,14 +974,14 @@         useDefaultTemplate           | reportingLevel == DetailedReports = True           | isJust installLogFile'            = False-          | parallelBuild                     = True+          | parallelInstall                   = True           | otherwise                         = False          overrideVerbosity :: Bool         overrideVerbosity           | reportingLevel == DetailedReports = True           | isJust installLogFile'            = True-          | parallelBuild                     = False+          | parallelInstall                   = False           | otherwise                         = False      substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath@@ -978,7 +1005,7 @@                    -> JobControl IO (PackageId, BuildResult)                    -> UseLogFile                    -> InstallPlan-                   -> (ConfiguredPackage -> IO BuildResult)+                   -> (ReadyPackage -> IO BuildResult)                    -> IO InstallPlan executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =     tryNewTasks 0 plan0@@ -1046,31 +1073,43 @@       mapM_ putStrLn (drop toDrop lns)  -- | Call an installer for an 'SourcePackage' but override the configure--- flags with the ones given by the 'ConfiguredPackage'. In particular the--- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly+-- flags with the ones given by the 'ReadyPackage'. In particular the+-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly -- versioned package dependencies. So we ignore any previous partial flag -- assignment or dependency constraints and use the new ones. ---installConfiguredPackage :: Platform -> CompilerId-                         ->  ConfigFlags -> ConfiguredPackage-                         -> (ConfigFlags -> PackageLocation (Maybe FilePath)-                                         -> PackageDescription-                                         -> PackageDescriptionOverride -> a)-                         -> a-installConfiguredPackage platform comp configFlags-  (ConfiguredPackage (SourcePackage _ gpkg source pkgoverride)+-- NB: when updating this function, don't forget to also update+-- 'configurePackage' in D.C.Configure.+installReadyPackage :: Platform -> CompilerId+                       -> ConfigFlags+                       -> ReadyPackage+                       -> (ConfigFlags -> PackageLocation (Maybe FilePath)+                                       -> PackageDescription+                                       -> PackageDescriptionOverride -> a)+                       -> a+installReadyPackage platform comp configFlags+  (ReadyPackage (SourcePackage _ gpkg source pkgoverride)    flags stanzas deps)   installPkg = installPkg configFlags {     configConfigurationsFlags = flags,-    configConstraints = map thisPackageVersion deps,-    configBenchmarks = toFlag False,-    configTests = toFlag (TestStanzas `elem` stanzas)+    -- We generate the legacy constraints as well as the new style precise deps.+    -- In the end only one set gets passed to Setup.hs configure, depending on+    -- the Cabal version we are talking to.+    configConstraints  = [ thisPackageVersion (packageId deppkg)+                         | deppkg <- deps ],+    configDependencies = [ (packageName (Installed.sourcePackageId deppkg),+                            Installed.installedPackageId deppkg)+                         | deppkg <- deps ],+    -- Use '--exact-configuration' if supported.+    configExactConfiguration = toFlag True,+    configBenchmarks         = toFlag False,+    configTests              = toFlag (TestStanzas `elem` stanzas)   } source pkg pkgoverride   where     pkg = case finalizePackageDescription flags            (const True)            platform comp [] (enableStanzas stanzas gpkg) of-      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Left _ -> error "finalizePackageDescription ReadyPackage failed"       Right (desc, _) -> desc  fetchSourcePackage@@ -1092,10 +1131,10 @@ installLocalPackage   :: Verbosity   -> JobLimit-  -> PackageIdentifier -> PackageLocation FilePath+  -> PackageIdentifier -> PackageLocation FilePath -> FilePath   -> (Maybe FilePath -> IO BuildResult)   -> IO BuildResult-installLocalPackage verbosity jobLimit pkgid location installPkg =+installLocalPackage verbosity jobLimit pkgid location distPref installPkg =    case location of @@ -1104,24 +1143,25 @@      LocalTarballPackage tarballPath ->       installLocalTarballPackage verbosity jobLimit-        pkgid tarballPath installPkg+        pkgid tarballPath distPref installPkg      RemoteTarballPackage _ tarballPath ->       installLocalTarballPackage verbosity jobLimit-        pkgid tarballPath installPkg+        pkgid tarballPath distPref installPkg      RepoTarballPackage _ _ tarballPath ->       installLocalTarballPackage verbosity jobLimit-        pkgid tarballPath installPkg+        pkgid tarballPath distPref installPkg   installLocalTarballPackage   :: Verbosity   -> JobLimit-  -> PackageIdentifier -> FilePath+  -> PackageIdentifier -> FilePath -> FilePath   -> (Maybe FilePath -> IO BuildResult)   -> IO BuildResult-installLocalTarballPackage verbosity jobLimit pkgid tarballPath installPkg = do+installLocalTarballPackage verbosity jobLimit pkgid+                           tarballPath distPref installPkg = do   tmp <- getTemporaryDirectory   withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->     onFailure UnpackFailed $ do@@ -1136,8 +1176,33 @@         exists <- doesFileExist descFilePath         when (not exists) $           die $ "Package .cabal file not found: " ++ show descFilePath+        maybeRenameDistDir absUnpackedPath+       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.+    --+    -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still+    -- fails even with this workaround. We probably can live with that.+    maybeRenameDistDir :: FilePath -> IO ()+    maybeRenameDistDir absUnpackedPath = do+      let distDirPath    = absUnpackedPath </> defaultDistPref+          distDirPathTmp = absUnpackedPath </> (defaultDistPref ++ "-tmp")+          distDirPathNew = absUnpackedPath </> distPref+      distDirExists <- doesDirectoryExist distDirPath+      when distDirExists $ do+        -- NB: we need to handle the case when 'distDirPathNew' is a+        -- subdirectory of 'distDirPath' (e.g. 'dist/dist-sandbox-3688fbc2').+        debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '"+          ++ distDirPathTmp ++ "'."+        renameDirectory distDirPath distDirPathTmp+        createDirectoryIfMissingVerbose verbosity False distDirPath+        debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '"+          ++ distDirPathNew ++ "'."+        renameDirectory distDirPathTmp distDirPathNew  installUnpackedPackage   :: Verbosity@@ -1158,7 +1223,7 @@   -> IO BuildResult installUnpackedPackage verbosity buildLimit installLock numJobs                        scriptOptions miscOptions-                       configFlags installConfigFlags haddockFlags+                       configFlags installFlags haddockFlags                        compid platform pkg pkgoverride workingDir useLogFile = do    -- Override the .cabal file if necessary@@ -1181,21 +1246,24 @@         configVerbosity = toFlag verbosity'       } +  -- Path to the optional log file.+  mLogPath <- maybeLogPath+   -- Configure phase   onFailure ConfigureFailed $ withJobLimit buildLimit $ do     when (numJobs > 1) $ notice verbosity $       "Configuring " ++ display pkgid ++ "..."-    setup configureCommand configureFlags+    setup configureCommand configureFlags mLogPath    -- Build phase     onFailure BuildFailed $ do       when (numJobs > 1) $ notice verbosity $         "Building " ++ display pkgid ++ "..."-      setup buildCommand' buildFlags+      setup buildCommand' buildFlags mLogPath    -- Doc generation phase       docsResult <- if shouldHaddock-        then (do setup haddockCommand haddockFlags'+        then (do setup haddockCommand haddockFlags' mLogPath                  return DocsOk)                `catchIO`   (\_ -> return DocsFailed)                `catchExit` (\_ -> return DocsFailed)@@ -1204,18 +1272,25 @@   -- Tests phase       onFailure TestsFailed $ do         when (testsEnabled && PackageDescription.hasTests pkg) $-            setup Cabal.testCommand testFlags+            setup Cabal.testCommand testFlags mLogPath          let testsResult | testsEnabled = TestsOk                         | otherwise = TestsNotTried        -- Install phase-        onFailure InstallFailed $ criticalSection installLock $+        onFailure InstallFailed $ criticalSection installLock $ do+          -- Capture installed package configuration file+          maybePkgConf <- maybeGenPkgConf mLogPath++          -- Actual installation           withWin32SelfUpgrade verbosity configFlags compid platform pkg $ do             case rootCmd miscOptions of               (Just cmd) -> reexec cmd-              Nothing    -> setup Cabal.installCommand installFlags-            return (Right (BuildOk docsResult testsResult))+              Nothing    -> do+                setup Cabal.copyCommand copyFlags mLogPath+                when shouldRegister $ do+                  setup Cabal.registerCommand registerFlags mLogPath+          return (Right (BuildOk docsResult testsResult maybePkgConf))    where     pkgid            = packageId pkg@@ -1224,20 +1299,28 @@       buildDistPref  = configDistPref configFlags,       buildVerbosity = toFlag verbosity'     }-    shouldHaddock    = fromFlag (installDocumentation installConfigFlags)+    shouldHaddock    = fromFlag (installDocumentation installFlags)     haddockFlags' _   = haddockFlags {       haddockVerbosity = toFlag verbosity',       haddockDistPref  = configDistPref configFlags     }     testsEnabled = fromFlag (configTests configFlags)+                   && fromFlagOrDefault False (installRunTests installFlags)     testFlags _ = Cabal.emptyTestFlags {       Cabal.testDistPref = configDistPref configFlags     }-    installFlags _   = Cabal.emptyInstallFlags {-      Cabal.installDistPref  = configDistPref configFlags,-      Cabal.installVerbosity = toFlag verbosity'+    copyFlags _ = Cabal.emptyCopyFlags {+      Cabal.copyDistPref   = configDistPref configFlags,+      Cabal.copyDest       = toFlag InstallDirs.NoCopyDest,+      Cabal.copyVerbosity  = toFlag verbosity'     }+    shouldRegister = PackageDescription.hasLibs pkg+    registerFlags _ = Cabal.emptyRegisterFlags {+      Cabal.regDistPref   = configDistPref configFlags,+      Cabal.regVerbosity  = toFlag verbosity'+    }     verbosity' = maybe verbosity snd useLogFile+    tempTemplate name = name ++ "-" ++ display pkgid      addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags     addDefaultInstallDirs configFlags' = do@@ -1254,30 +1337,59 @@           userInstall = fromFlagOrDefault defaultUserInstall                         (configUserInstall configFlags') -    setup cmd flags  = do+    maybeGenPkgConf :: Maybe FilePath+                    -> IO (Maybe Installed.InstalledPackageInfo)+    maybeGenPkgConf mLogPath =+      if shouldRegister then do+        tmp <- getTemporaryDirectory+        withTempFile tmp (tempTemplate "pkgConf") $ \pkgConfFile handle -> do+          hClose handle+          let registerFlags' version = (registerFlags version) {+                Cabal.regGenPkgConf = toFlag (Just pkgConfFile)+              }+          setup Cabal.registerCommand registerFlags' mLogPath+          withFileContents pkgConfFile $ \pkgConfText ->+            case Installed.parseInstalledPackageInfo pkgConfText of+              Installed.ParseFailed perror    -> pkgConfParseFailed perror+              Installed.ParseOk warns pkgConf -> do+                unless (null warns) $+                  warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)+                return (Just pkgConf)+      else return Nothing++    pkgConfParseFailed :: Installed.PError -> IO a+    pkgConfParseFailed perror =+      die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"+            ++ show perror++    maybeLogPath :: IO (Maybe FilePath)+    maybeLogPath =+      case useLogFile of+         Nothing                 -> return Nothing+         Just (mkLogFileName, _) -> do+           let logFileName = mkLogFileName (packageId pkg)+               logDir      = takeDirectory logFileName+           unless (null logDir) $ createDirectoryIfMissing True logDir+           logFileExists <- doesFileExist logFileName+           when logFileExists $ removeFile logFileName+           return (Just logFileName)++    setup cmd flags mLogPath =       Exception.bracket-              (case useLogFile of-               Nothing                   -> return Nothing-               Just (mkLogFileName, _) -> do-                 let logFileName = mkLogFileName (packageId pkg)-                     logDir      = takeDirectory logFileName-                 unless (null logDir) $ createDirectoryIfMissing True logDir-                 logFile <- openFile logFileName WriteMode-                 return (Just logFile))-              (\mHandle -> case mHandle of-                           Just handle -> hClose handle-                           Nothing -> return ())-              (\logFileHandle ->-               setupWrapper verbosity-                 scriptOptions { useLoggingHandle = logFileHandle-                               , useWorkingDir    = workingDir }-                 (Just pkg)-                 cmd flags [])+      (maybe (return Nothing)+             (\path -> Just `fmap` openFile path AppendMode) mLogPath)+      (maybe (return ()) hClose)+      (\logFileHandle ->+        setupWrapper verbosity+          scriptOptions { useLoggingHandle = logFileHandle+                        , useWorkingDir    = workingDir }+          (Just pkg)+          cmd flags [])+     reexec cmd = do-      -- look for our on executable file and re-exec ourselves using-      -- a helper program like sudo to elevate priviledges:-      bindir <- getBinDir-      let self = bindir </> "cabal" <.> exeExtension+      -- look for our own executable file and re-exec ourselves using a helper+      -- program like sudo to elevate privileges:+      self <- getExecutablePath       weExist <- doesFileExist self       if weExist         then inDir workingDir $@@ -1300,7 +1412,7 @@   -- --------------------------------------------------------------- * Wierd windows hacks+-- * Weird windows hacks -- ------------------------------------------------------------  withWin32SelfUpgrade :: Verbosity

Distribution/Client/InstallPlan.hs view

@@ -47,7 +47,9 @@  import Distribution.Client.Types          ( SourcePackage(packageDescription), ConfiguredPackage(..)-         , InstalledPackage, BuildFailure, BuildSuccess, enableStanzas )+         , ReadyPackage(..), readyPackageToConfiguredPackage+         , InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas+         , InstalledPackage (..) ) import Distribution.Package          ( PackageIdentifier(..), PackageName(..), Package(..), packageName          , PackageFixedDeps(..), Dependency(..) )@@ -73,11 +75,12 @@          ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils          ( comparing, intercalate )+import qualified Distribution.InstalledPackageInfo as Installed  import Data.List          ( sort, sortBy ) import Data.Maybe-         ( fromMaybe )+         ( fromMaybe, maybeToList ) import qualified Data.Graph as Graph import Data.Graph (Graph) import Control.Exception@@ -127,9 +130,11 @@  data PlanPackage = PreExisting InstalledPackage                  | Configured  ConfiguredPackage-                 | Processing  ConfiguredPackage-                 | Installed   ConfiguredPackage BuildSuccess+                 | Processing  ReadyPackage+                 | Installed   ReadyPackage BuildSuccess                  | Failed      ConfiguredPackage BuildFailure+                   -- ^ NB: packages in the Failed state can be *either* Ready+                   -- or Configured.  instance Package PlanPackage where   packageId (PreExisting pkg) = packageId pkg@@ -204,7 +209,7 @@ -- configured state and have all their dependencies installed already. -- The plan is complete if the result is @[]@. ---ready :: InstallPlan -> [ConfiguredPackage]+ready :: InstallPlan -> [ReadyPackage] ready plan = assert check readyPackages   where     check = if null readyPackages && null processingPackages@@ -212,23 +217,37 @@               else True     configuredPackages = [ pkg | Configured pkg <- toList plan ]     processingPackages = [ pkg | Processing pkg <- toList plan]-    readyPackages = filter (all isInstalled . depends) configuredPackages-    isInstalled pkg =-      case PackageIndex.lookupPackageId (planIndex plan) pkg of-        Just (Configured  _) -> False-        Just (Processing  _) -> False-        Just (Failed    _ _) -> internalError depOnFailed-        Just (PreExisting _) -> True-        Just (Installed _ _) -> True-        Nothing              -> internalError incomplete++    readyPackages :: [ReadyPackage]+    readyPackages =+      [ ReadyPackage srcPkg flags stanzas deps+      | pkg@(ConfiguredPackage srcPkg flags stanzas _) <- configuredPackages+        -- select only the package that have all of their deps installed:+      , deps <- maybeToList (hasAllInstalledDeps pkg)+      ]++    hasAllInstalledDeps :: ConfiguredPackage -> Maybe [Installed.InstalledPackageInfo]+    hasAllInstalledDeps = mapM isInstalledDep . depends++    isInstalledDep :: PackageIdentifier -> Maybe Installed.InstalledPackageInfo+    isInstalledDep pkgid =+      case PackageIndex.lookupPackageId (planIndex plan) pkgid of+        Just (Configured  _)                            -> Nothing+        Just (Processing  _)                            -> Nothing+        Just (Failed    _ _)                            -> internalError depOnFailed+        Just (PreExisting (InstalledPackage instPkg _)) -> Just instPkg+        Just (Installed _ (BuildOk _ _ (Just instPkg))) -> Just instPkg+        Just (Installed _ (BuildOk _ _ Nothing))        -> internalError depOnNonLib+        Nothing                                         -> internalError incomplete     incomplete  = "install plan is not closed"     depOnFailed = "configured package depends on failed package"+    depOnNonLib = "configured package depends on a non-library package"  -- | Marks packages in the graph as currently processing (e.g. building). -- -- * The package must exist in the graph and be in the configured state. ---processing :: [ConfiguredPackage] -> InstallPlan -> InstallPlan+processing :: [ReadyPackage] -> InstallPlan -> InstallPlan processing pkgs plan = assert (invariant plan') plan'   where     plan' = plan {@@ -270,7 +289,7 @@                }     pkg      = lookupProcessingPackage plan pkgid     failures = PackageIndex.fromList-             $ Failed pkg buildResult+             $ Failed (readyPackageToConfiguredPackage pkg) buildResult              : [ Failed pkg' buildResult'                | Just pkg' <- map checkConfiguredPackage                             $ packagesThatDependOn plan pkgid ]@@ -287,7 +306,7 @@ -- | Lookup a package that we expect to be in the processing state. -- lookupProcessingPackage :: InstallPlan-                        -> PackageIdentifier -> ConfiguredPackage+                        -> PackageIdentifier -> ReadyPackage lookupProcessingPackage plan pkgid =   case PackageIndex.lookupPackageId (planIndex plan) pkgid of     Just (Processing pkg) -> pkg@@ -302,7 +321,7 @@   internalError $ "not configured or no such pkg " ++ display (packageId pkg)  -- --------------------------------------------------------------- * Checking valididy of plans+-- * Checking validity of plans -- ------------------------------------------------------------  -- | A valid installation plan is a set of packages that is 'acyclic',@@ -330,7 +349,7 @@  showPlanProblem (PackageMissingDeps pkg missingDeps) =      "Package " ++ display (packageId pkg)-  ++ " depends on the following packages which are missing from the plan "+  ++ " depends on the following packages which are missing from the plan: "   ++ intercalate ", " (map display missingDeps)  showPlanProblem (PackageCycle cycleGroup) =@@ -409,11 +428,11 @@ -- most one version of any package in the set. It only requires that of -- packages which have more than one other package depending on them. We could -- actually make the condition even more precise and say that different--- versions are ok so long as they are not both in the transitive closure of+-- versions are OK so long as they are not both in the transitive closure of -- any other package (or equivalently that their inverse closures do not -- intersect). The point is we do not want to have any packages depending -- directly or indirectly on two different versions of the same package. The--- current definition is just a safe aproximation of that.+-- current definition is just a safe approximation of that. -- -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to --   find out which packages are.

Distribution/Client/InstallSymlink.hs view

@@ -35,7 +35,7 @@ #else  import Distribution.Client.Types-         ( SourcePackage(..), ConfiguredPackage(..), enableStanzas )+         ( SourcePackage(..), ReadyPackage(..), enableStanzas ) import Distribution.Client.Setup          ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan@@ -77,18 +77,18 @@ -- directory will be on the user's PATH. However some people are a bit nervous -- about letting a package manager install programs into @~/bin/@. ----- A comprimise solution is that instead of installing binaries directly into+-- A compromise solution is that instead of installing binaries directly into -- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ -- and then create symlinks in @~/bin/@. We can be careful when setting up the -- symlinks that we do not overwrite any binary that the user installed. We can -- check if it was a symlink we made because it would point to the private dir -- where we install our binaries. This means we can install normally without -- worrying and in a later phase set up symlinks, and if that fails then we--- report it to the user, but even in this case the package is still in an ok+-- report it to the user, but even in this case the package is still in an OK -- installed state. -- -- This is an optional feature that users can choose to use or not. It is--- controlled from the config file. Of course it only works on posix systems+-- controlled from the config file. Of course it only works on POSIX systems -- with symlinks so is not available to Windows users. -- symlinkBinaries :: ConfigFlags@@ -127,12 +127,12 @@       , exe <- PackageDescription.executables pkg       , PackageDescription.buildable (PackageDescription.buildInfo exe) ] -    pkgDescription :: ConfiguredPackage -> PackageDescription-    pkgDescription (ConfiguredPackage (SourcePackage _ pkg _ _) flags stanzas _) =+    pkgDescription :: ReadyPackage -> PackageDescription+    pkgDescription (ReadyPackage (SourcePackage _ pkg _ _) flags stanzas _) =       case finalizePackageDescription flags              (const True)              platform compilerId [] (enableStanzas stanzas pkg) of-        Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+        Left _ -> error "finalizePackageDescription ReadyPackage failed"         Right (desc, _) -> desc      -- This is sadly rather complicated. We're kind of re-doing part of the@@ -168,7 +168,7 @@                           --   bin dir, eg @foo@               -> String   -- ^ The name of the executable to in the private bin                           --   dir, eg @foo-1.0@-              -> IO Bool  -- ^ If creating the symlink was sucessful. @False@+              -> IO Bool  -- ^ If creating the symlink was successful. @False@                           --   if there was another file there already that we                           --   did not own. Other errors like permission errors                           --   just propagate as exceptions.@@ -185,11 +185,11 @@                                 (publicBindir   </> publicName)     rmLink = removeLink (publicBindir </> publicName) --- | Check a filepath of a symlink that we would like to create to see if it--- is ok. For it to be ok to overwrite it must either not already exist yet or+-- | Check a file path of a symlink that we would like to create to see if it+-- is OK. For it to be OK to overwrite it must either not already exist yet or -- be a symlink to our target (in which case we can assume ownership). ---targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private+targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private                                 -- binary that we would like to create                     -> FilePath -- ^ The canonical path of the private binary.                                 -- Use 'canonicalizePath' to make this.@@ -214,7 +214,7 @@ data SymlinkStatus    = NotExists     -- ^ The file doesn't exist so we can make a symlink.    | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll-                   -- have to delete it first bemore we make a new symlink.+                   -- have to delete it first before we make a new symlink.    | NotOurFile    -- ^ A file already exists and it is not one of our existing                    -- symlinks (either because it is not a symlink or because                    -- it points somewhere other than our managed space).

Distribution/Client/List.hs view

@@ -70,17 +70,16 @@          ( doesDirectoryExist )  --- |Show information about packages-list :: Verbosity-     -> PackageDBStack-     -> [Repo]-     -> Compiler-     -> ProgramConfiguration-     -> ListFlags-     -> [String]-     -> IO ()-list verbosity packageDBs repos comp conf listFlags pats = do-+-- | Return a list of packages matching given search strings.+getPkgList :: Verbosity+           -> PackageDBStack+           -> [Repo]+           -> Compiler+           -> ProgramConfiguration+           -> ListFlags+           -> [String]+           -> IO [PackageDisplayInfo]+getPkgList verbosity packageDBs repos comp conf listFlags pats = do     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf     sourcePkgDb       <- getSourcePackages    verbosity repos     let sourcePkgIndex = packageIndex sourcePkgDb@@ -104,7 +103,27 @@                   , not onlyInstalled || not (null installedPkgs)                   , let pref        = prefs pkgname                         selectedPkg = latestWithPref pref sourcePkgs ]+    return matches+  where+    onlyInstalled = fromFlag (listInstalled listFlags)+    matchingPackages search index =+      [ pkg+      | pat <- pats+      , pkg <- search index pat ] ++-- | Show information about packages.+list :: Verbosity+     -> PackageDBStack+     -> [Repo]+     -> Compiler+     -> ProgramConfiguration+     -> ListFlags+     -> [String]+     -> IO ()+list verbosity packageDBs repos comp conf listFlags pats = do+    matches <- getPkgList verbosity packageDBs repos comp conf listFlags pats+     if simpleOutput       then putStr $ unlines              [ display (pkgName pkg) ++ " " ++ display version@@ -124,11 +143,6 @@     onlyInstalled = fromFlag (listInstalled listFlags)     simpleOutput  = fromFlag (listSimpleOutput listFlags) -    matchingPackages search index =-      [ pkg-      | pat <- pats-      , pkg <- search index pat ]- info :: Verbosity      -> PackageDBStack      -> [Repo]@@ -226,7 +240,7 @@   -- | The info that we can display for each package. It is information per--- package name and covers all installed and avilable versions.+-- package name and covers all installed and available versions. -- data PackageDisplayInfo = PackageDisplayInfo {     pkgName           :: PackageName,

Distribution/Client/PackageIndex.hs view

@@ -76,7 +76,7 @@  -- | The collection of information about packages from one or more 'PackageDB's. ----- It can be searched effeciently by package name and version.+-- It can be searched efficiently by package name and version. -- newtype PackageIndex pkg = PackageIndex   -- This index package names to all the package records matching that package@@ -89,6 +89,9 @@    deriving (Show, Read) +instance Functor PackageIndex where+  fmap f (PackageIndex m) = PackageIndex (fmap (map f) m)+ instance Package pkg => Monoid (PackageIndex pkg) where   mempty  = PackageIndex Map.empty   mappend = merge@@ -282,12 +285,12 @@  -- | Does a case-insensitive search by package name. ----- If there is only one package that compares case-insentiviely to this name+-- If there is only one package that compares case-insensitively to this name -- then the search is unambiguous and we get back all versions of that package.--- If several match case-insentiviely but one matches exactly then it is also+-- If several match case-insensitively but one matches exactly then it is also -- unambiguous. ----- If however several match case-insentiviely and none match exactly then we+-- If however several match case-insensitively and none match exactly then we -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists.

Distribution/Client/ParseUtils.hs view

@@ -16,7 +16,7 @@          ( Field(..) )  import Control.Monad    ( foldM )-import Text.PrettyPrint ( (<>), (<+>), ($$) )+import Text.PrettyPrint ( (<>), (<+>), ($+$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp          ( Doc, text, colon, vcat, empty, isEmpty, nest )@@ -52,6 +52,11 @@   | otherwise        = Disp.text name <> Disp.colon <+> cur  ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc-ppSection name arg fields def cur =-     Disp.text name <+> Disp.text arg-  $$ Disp.nest 2 (ppFields fields def cur)+ppSection name arg fields def cur+  | Disp.isEmpty fieldsDoc = Disp.empty+  | otherwise              = Disp.text name <+> argDoc+                             $+$ (Disp.nest 2 fieldsDoc)+  where+    fieldsDoc = ppFields fields def cur+    argDoc | arg == "" = Disp.empty+           | otherwise = Disp.text arg

Distribution/Client/Sandbox.hs view

@@ -33,6 +33,7 @@     tryGetIndexFilePath,     sandboxBuildDir,     getInstalledPackagesInSandbox,+    updateSandboxConfigFileFlag,      -- FIXME: move somewhere else     configPackageDB', configCompilerAux'@@ -77,9 +78,9 @@ import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)                                               , fromFlagOrDefault ) import Distribution.Simple.SrcDist            ( prepareTree )-import Distribution.Simple.Utils              ( die, debug, notice, warn+import Distribution.Simple.Utils              ( die, debug, notice, info, warn                                               , debugNoWrap, defaultPackageDesc-                                              , findPackageDesc+                                              , tryFindPackageDesc                                               , intercalate, topHandlerWith                                               , createDirectoryIfMissingVerbose ) import Distribution.Package                   ( Package(..) )@@ -99,7 +100,7 @@ import Data.Char                              ( ord ) import Data.IORef                             ( newIORef, writeIORef, readIORef ) import Data.List                              ( delete, foldl' )-import Data.Maybe                             ( fromJust )+import Data.Maybe                             ( fromJust, fromMaybe ) import Data.Monoid                            ( mempty, mappend ) import Data.Word                              ( Word32 ) import Numeric                                ( showHex )@@ -154,14 +155,17 @@ -- * Basic sandbox functions. -- --- | Return the path to the package environment directory - either the current--- directory or the one that @--sandbox-config-file@ resides in.-getPkgEnvDir :: GlobalFlags -> IO FilePath-getPkgEnvDir globalFlags = do-  let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags-  case sandboxConfigFileFlag of-    NoFlag    -> getCurrentDirectory-    Flag path -> tryCanonicalizePath . takeDirectory $ path+-- | If @--sandbox-config-file@ wasn't given on the command-line, set it to the+-- value of the @CABAL_SANDBOX_CONFIG@ environment variable, or else to+-- 'NoFlag'.+updateSandboxConfigFileFlag :: GlobalFlags -> IO GlobalFlags+updateSandboxConfigFileFlag globalFlags =+  case globalSandboxConfigFile globalFlags of+    Flag _ -> return globalFlags+    NoFlag -> do+      f' <- fmap (fromMaybe NoFlag . fmap Flag) . lookupEnv+            $ "CABAL_SANDBOX_CONFIG"+      return globalFlags { globalSandboxConfigFile = f' }  -- | Return the path to the sandbox config file - either the default or the one -- specified with @--sandbox-config-file@.@@ -265,14 +269,14 @@   when packageDBExists $     debug verbosity $ "The package database already exists: " ++ dbPath --- | Entry point for the 'cabal dump-pkgenv' command.+-- | Entry point for the 'cabal sandbox dump-pkgenv' command. dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do   (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags   commentPkgEnv        <- commentPackageEnvironment sandboxDir   putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv --- | Entry point for the 'cabal sandbox-init' command.+-- | Entry point for the 'cabal sandbox init' command. sandboxInit :: Verbosity -> SandboxFlags  -> GlobalFlags -> IO () sandboxInit verbosity sandboxFlags globalFlags = do   -- Warn if there's a 'cabal-dev' sandbox.@@ -316,7 +320,7 @@   maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile     (compilerId comp) platform --- | Entry point for the 'cabal sandbox-delete' command.+-- | Entry point for the 'cabal sandbox delete' command. sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO () sandboxDelete verbosity _sandboxFlags globalFlags = do   (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty@@ -458,8 +462,8 @@     notice verbosity $ "\nTo unregister source dependencies, "                        ++ "use the 'sandbox delete-source' command." --- | Invoke the @hc-pkg@ tool with provided arguments, restricted to the--- sandbox.+-- | Entry point for the 'cabal sandbox hc-pkg' command. Invokes the @hc-pkg@+-- tool with provided arguments, restricted to the sandbox. sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO () sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do   (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags@@ -478,14 +482,13 @@                              -> Flag Bool    -- ^ Ignored if we're in a sandbox.                              -> IO (UseSandbox, SavedConfig) loadConfigOrSandboxConfig verbosity globalFlags userInstallFlag = do-  let configFileFlag        = globalConfigFile globalFlags+  let configFileFlag        = globalConfigFile        globalFlags       sandboxConfigFileFlag = globalSandboxConfigFile globalFlags--  pkgEnvDir  <- getPkgEnvDir globalFlags-  pkgEnvType <- case sandboxConfigFileFlag of-    NoFlag -> classifyPackageEnvironment pkgEnvDir-    Flag _ -> return SandboxPackageEnvironment+      ignoreSandboxFlag     = globalIgnoreSandbox globalFlags +  pkgEnvDir  <- getPkgEnvDir sandboxConfigFileFlag+  pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag+                                           ignoreSandboxFlag   case pkgEnvType of     -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.     SandboxPackageEnvironment -> do@@ -498,13 +501,36 @@     UserPackageEnvironment    -> do       config <- loadConfig verbosity configFileFlag userInstallFlag       userConfig <- loadUserConfig verbosity pkgEnvDir-      return (NoSandbox, config `mappend` userConfig)+      let config' = config `mappend` userConfig+      dieIfSandboxRequired config'+      return (NoSandbox, config')      -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.     AmbientPackageEnvironment -> do       config <- loadConfig verbosity configFileFlag userInstallFlag+      dieIfSandboxRequired config       return (NoSandbox, config) +  where+    -- Return the path to the package environment directory - either the+    -- current directory or the one that @--sandbox-config-file@ resides in.+    getPkgEnvDir :: (Flag FilePath) -> IO FilePath+    getPkgEnvDir sandboxConfigFileFlag = do+      case sandboxConfigFileFlag of+        NoFlag    -> getCurrentDirectory+        Flag path -> tryCanonicalizePath . takeDirectory $ path++    -- Die if @--require-sandbox@ was specified and we're not inside a sandbox.+    dieIfSandboxRequired :: SavedConfig -> IO ()+    dieIfSandboxRequired config = checkFlag flag+      where+        flag = (globalRequireSandbox . savedGlobalFlags $ config)+               `mappend` (globalRequireSandbox globalFlags)+        checkFlag (Flag True)  =+          die $ "'require-sandbox' is set to True, but no sandbox is present."+        checkFlag (Flag False) = return ()+        checkFlag (NoFlag)     = return ()+ -- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do -- nothing. maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a@@ -594,7 +620,7 @@                        configFlags comp conf    -- Get the package descriptions for all add-source deps.-  depsCabalFiles <- mapM findPackageDesc buildTreeRefs+  depsCabalFiles <- mapM tryFindPackageDesc buildTreeRefs   depsPkgDescs   <- mapM (readPackageDescription verbosity) depsCabalFiles   let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)       isInstalled pkgid = not . null@@ -611,9 +637,10 @@       modifiedDepsMap = M.fromList modifiedDeps    assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())-  unless (null modifiedDeps) $-    notice verbosity $ "Some add-source dependencies have been modified. "-                       ++ "They will be reinstalled..."+  if (null modifiedDeps)+    then info   verbosity $ "Found no modified add-source deps."+    else notice verbosity $ "Some add-source dependencies have been modified. "+                            ++ "They will be reinstalled..."    -- Get the package ids of the remaining add-source deps (some are possibly not   -- installed).@@ -650,19 +677,16 @@                                -> ConfigFlags      -- ^ Saved configure flags                                                    -- (from dist/setup-config)                                -> GlobalFlags-                               -> IO (UseSandbox, WereDepsReinstalled)+                               -> IO (UseSandbox, SavedConfig+                                     ,WereDepsReinstalled) maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do-  currentDir <- getCurrentDirectory-  pkgEnvType <- classifyPackageEnvironment currentDir-  case pkgEnvType of-    AmbientPackageEnvironment -> return (NoSandbox, NoDepsReinstalled)-    UserPackageEnvironment    -> return (NoSandbox, NoDepsReinstalled)-    SandboxPackageEnvironment -> do-      (sandboxDir, pkgEnv)    <- tryLoadSandboxConfig verbosity globalFlags'--      -- Actually reinstall the modified add-source deps.-      let config         = pkgEnvSavedConfig pkgEnv-          configFlags    = savedConfigureFlags config+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags'+                          (configUserInstall configFlags')+  case useSandbox of+    NoSandbox             -> return (NoSandbox, config, NoDepsReinstalled)+    UseSandbox sandboxDir -> do+      -- Reinstall the modified add-source deps.+      let configFlags    = savedConfigureFlags config                            `mappendSomeSavedFlags`                            configFlags'           configExFlags  = defaultConfigExFlags@@ -681,7 +705,7 @@       depsReinstalled <- reinstallAddSourceDeps verbosity                          configFlags configExFlags installFlags globalFlags                          sandboxDir-      return (UseSandbox sandboxDir, depsReinstalled)+      return (UseSandbox sandboxDir, config, depsReinstalled)    where @@ -702,10 +726,11 @@         configProgramPaths = configProgramPaths sandboxConfigFlags                              `mappend` configProgramPaths savedFlags,         configProgramArgs  = configProgramArgs sandboxConfigFlags-                             `mappend` configProgramArgs savedFlags-        -- NOTE: We don't touch the @configPackageDBs@ field because-        -- @sandboxConfigFlags@ contains the sandbox location which was set when-        -- creating @cabal.sandbox.config@.+                             `mappend` configProgramArgs savedFlags,+        -- NOTE: Unconditionally choosing the value from+        -- 'dist/setup-config'. Sandbox package DB location may have been+        -- changed by 'configure -w'.+        configPackageDBs   = configPackageDBs savedFlags         -- FIXME: Is this compatible with the 'inherit' feature?         }

Distribution/Client/Sandbox/Index.hs view

@@ -31,7 +31,7 @@                                  , makeAbsoluteToCwd, tryCanonicalizePath                                  , canonicalizePathNoThrow ) -import Distribution.Simple.Utils ( die, debug, findPackageDesc )+import Distribution.Simple.Utils ( die, debug, tryFindPackageDesc ) import Distribution.Verbosity    ( Verbosity )  import qualified Data.ByteString.Lazy as BS@@ -61,7 +61,7 @@   dirExists <- doesDirectoryExist dir   unless dirExists $     die $ "directory '" ++ dir ++ "' does not exist"-  _ <- findPackageDesc dir+  _ <- tryFindPackageDesc dir   return . Just $ BuildTreeRef refType dir  -- | Given a tar archive entry, try to parse it as a local build tree reference.

Distribution/Client/Sandbox/PackageEnvironment.hs view

@@ -19,6 +19,7 @@   , showPackageEnvironment   , showPackageEnvironmentWithComments   , setPackageDB+  , sandboxPackageDBPath   , loadUserConfig    , basePackageEnvironment@@ -28,9 +29,12 @@   , userPackageEnvironmentFile   ) where -import Distribution.Client.Config      ( SavedConfig(..), commentSavedConfig,-                                         loadConfig, configFieldDescriptions,-                                         installDirsFields, defaultCompiler )+import Distribution.Client.Config      ( SavedConfig(..), commentSavedConfig+                                       , loadConfig, configFieldDescriptions+                                       , haddockFlagsFields+                                       , installDirsFields, withProgramsFields+                                       , withProgramOptionsFields+                                       , defaultCompiler ) import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection ) import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)                                        , InstallFlags(..)@@ -40,22 +44,25 @@ import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate                                        , defaultInstallDirs, combineInstallDirs                                        , fromPathTemplate, toPathTemplate )-import Distribution.Simple.Setup       ( Flag(..), ConfigFlags(..),-                                         fromFlagOrDefault, toFlag )-import Distribution.Simple.Utils       ( die, info, notice, warn, lowercase )-import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..),-                                         commaListField,-                                         liftField, lineNo, locatedErrorMsg,-                                         parseFilePathQ, readFields,-                                         showPWarning, simpleField, syntaxError )+import Distribution.Simple.Setup       ( Flag(..)+                                       , ConfigFlags(..), HaddockFlags(..)+                                       , fromFlagOrDefault, toFlag, flagToMaybe )+import Distribution.Simple.Utils       ( die, info, notice, warn )+import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..)+                                       , commaListField, commaNewLineListField+                                       , liftField, lineNo, locatedErrorMsg+                                       , parseFilePathQ, readFields+                                       , showPWarning, simpleField+                                       , syntaxError, warning ) import Distribution.System             ( Platform ) import Distribution.Verbosity          ( Verbosity, normal )-import Control.Monad                   ( foldM, when, unless )+import Control.Monad                   ( foldM, liftM2, when, unless ) import Data.List                       ( partition )+import Data.Maybe                      ( isJust ) import Data.Monoid                     ( Monoid(..) ) import Distribution.Compat.Exception   ( catchIO )-import System.Directory                ( doesDirectoryExist, doesFileExist,-                                         renameFile )+import System.Directory                ( doesDirectoryExist, doesFileExist+                                       , renameFile ) import System.FilePath                 ( (<.>), (</>), takeDirectory ) import System.IO.Error                 ( isDoesNotExistError ) import Text.PrettyPrint                ( ($+$) )@@ -110,17 +117,24 @@  -- | Is there a 'cabal.sandbox.config' or 'cabal.config' in this -- directory?-classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType-classifyPackageEnvironment pkgEnvDir = do-  isSandbox <- configExists sandboxPackageEnvironmentFile-  isUser    <- configExists userPackageEnvironmentFile-  case (isSandbox, isUser) of-    (True,  _)     -> return SandboxPackageEnvironment-    (False, True)  -> return UserPackageEnvironment-    (False, False) -> return AmbientPackageEnvironment+classifyPackageEnvironment :: FilePath -> Flag FilePath -> Flag Bool+                              -> IO PackageEnvironmentType+classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag ignoreSandboxFlag =+  do isSandbox <- liftM2 (||) (return forceSandboxConfig)+                  (configExists sandboxPackageEnvironmentFile)+     isUser    <- configExists userPackageEnvironmentFile+     return (classify isSandbox isUser)   where-    configExists fname = doesFileExist (pkgEnvDir </> fname)+    configExists fname   = doesFileExist (pkgEnvDir </> fname)+    ignoreSandbox        = fromFlagOrDefault False ignoreSandboxFlag+    forceSandboxConfig   = isJust . flagToMaybe $ sandboxConfigFileFlag +    classify :: Bool -> Bool -> PackageEnvironmentType+    classify True _+      | not ignoreSandbox = SandboxPackageEnvironment+    classify _    True    = UserPackageEnvironment+    classify _    False   = AmbientPackageEnvironment+ -- | Defaults common to 'initialPackageEnvironment' and -- 'commentPackageEnvironment'. commonPackageEnvironmentConfig :: FilePath -> SavedConfig@@ -197,14 +211,23 @@        }     } +-- | Return the path to the sandbox package database.+sandboxPackageDBPath :: FilePath -> Compiler -> Platform -> String+sandboxPackageDBPath sandboxDir compiler platform =+    sandboxDir+         </> (Text.display platform ++ "-"+             ++ showCompilerId compiler+             ++ "-packages.conf.d")++ -- | Use the package DB location specific for this compiler. setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags setPackageDB sandboxDir compiler platform configFlags =   configFlags {-    configPackageDBs = [Just (SpecificPackageDB $ sandboxDir-                              </> (Text.display platform ++ "-"-                                   ++ showCompilerId compiler-                                   ++ "-packages.conf.d"))]+    configPackageDBs = [Just (SpecificPackageDB $ sandboxPackageDBPath+                                                      sandboxDir+                                                      compiler+                                                      platform)]     }  -- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are@@ -320,7 +343,8 @@   inherited <- inheritedPackageEnvironment verbosity user    -- Layer the package environment settings over settings from ~/.cabal/config.-  cabalConfig <- loadConfig verbosity configFileFlag NoFlag+  cabalConfig <- fmap unsetSymlinkBinDir $+                 loadConfig verbosity configFileFlag NoFlag   return (sandboxDir,           updateInstallDirs $           (base `mappend` (toPkgEnv cabalConfig) `mappend`@@ -330,8 +354,8 @@       toPkgEnv config = mempty { pkgEnvSavedConfig = config }        updateInstallDirs pkgEnv =-        let config         = pkgEnvSavedConfig pkgEnv-            configureFlags = savedConfigureFlags config+        let config         = pkgEnvSavedConfig    pkgEnv+            configureFlags = savedConfigureFlags  config             installDirs    = savedUserInstallDirs config         in pkgEnv {           pkgEnvSavedConfig = config {@@ -341,6 +365,16 @@              }           } +      -- We don't want to inherit the value of 'symlink-bindir' from+      -- '~/.cabal/config'. See #1514.+      unsetSymlinkBinDir config =+        let installFlags = savedInstallFlags config+        in config {+          savedInstallFlags = installFlags {+             installSymlinkBinDir = NoFlag+             }+          }+ -- | Should the generated package environment file include comments? data IncludeComments = IncludeComments | NoComments @@ -368,7 +402,7 @@     pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })      -- FIXME: Should we make these fields part of ~/.cabal/config ?-  , commaListField "constraints"+  , commaNewLineListField "constraints"     Text.disp Text.parse     (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)     (\v pkgEnv -> updateConfigureExFlags pkgEnv@@ -426,10 +460,20 @@   pkgEnv <- parse others   let config       = pkgEnvSavedConfig pkgEnv       installDirs0 = savedUserInstallDirs config-  -- 'install-dirs' is the only section that we care about.-  installDirs <- foldM parseSection installDirs0 knownSections+  (haddockFlags, installDirs, paths, args) <-+    foldM parseSections+    (savedHaddockFlags config, installDirs0, [], [])+    knownSections   return pkgEnv {     pkgEnvSavedConfig = config {+       savedConfigureFlags    = (savedConfigureFlags config) {+          configProgramPaths  = paths,+          configProgramArgs   = args+          },+       savedHaddockFlags      = haddockFlags {+         haddockProgramPaths  = paths,+         haddockProgramArgs   = args+         },        savedUserInstallDirs   = installDirs,        savedGlobalInstallDirs = installDirs        }@@ -437,26 +481,54 @@    where     isKnownSection :: ParseUtils.Field -> Bool-    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True-    isKnownSection _                                         = False+    isKnownSection (ParseUtils.Section _ "haddock" _ _)                 = True+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True+    isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True+    isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True+    isKnownSection _                                                    = False      parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment     parse = parseFields pkgEnvFieldDescrs initial -    parseSection :: InstallDirs (Flag PathTemplate)-                    -> ParseUtils.Field-                    -> ParseResult (InstallDirs (Flag PathTemplate))-    parseSection accum (ParseUtils.Section line "install-dirs" name fs)-      | name' == "" = do accum' <- parseFields installDirsFields accum fs-                         return accum'-      | otherwise   =+    parseSections :: SectionsAccum -> ParseUtils.Field+                     -> ParseResult SectionsAccum+    parseSections accum@(h,d,p,a)+                 (ParseUtils.Section _ "haddock" name fs)+      | name == "" = do h' <- parseFields haddockFlagsFields h fs+                        return (h', d, p, a)+      | otherwise  = do+          warning "The 'haddock' section should be unnamed"+          return accum+    parseSections (h,d,p,a)+                  (ParseUtils.Section line "install-dirs" name fs)+      | name == "" = do d' <- parseFields installDirsFields d fs+                        return (h, d',p,a)+      | otherwise  =         syntaxError line $         "Named 'install-dirs' section: '" ++ name         ++ "'. Note that named 'install-dirs' sections are not allowed in the '"         ++ userPackageEnvironmentFile ++ "' file."-      where name' = lowercase name-    parseSection _accum f =-      syntaxError (lineNo f)  "Unrecognized stanza."+    parseSections accum@(h, d,p,a)+                  (ParseUtils.Section _ "program-locations" name fs)+      | name == "" = do p' <- parseFields withProgramsFields p fs+                        return (h, d, p', a)+      | otherwise  = do+          warning "The 'program-locations' section should be unnamed"+          return accum+    parseSections accum@(h, d, p, a)+                  (ParseUtils.Section _ "program-default-options" name fs)+      | name == "" = do a' <- parseFields withProgramOptionsFields a fs+                        return (h, d, p, a')+      | otherwise  = do+          warning "The 'program-default-options' section should be unnamed"+          return accum+    parseSections accum f = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo f)+      return accum++-- | Accumulator type for 'parseSections'.+type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate)+                     , [(String, FilePath)], [(String, [String])])  -- | Write out the package environment file. writePackageEnvironmentFile :: FilePath -> IncludeComments

Distribution/Client/Sandbox/Timestamp.hs view

@@ -13,7 +13,6 @@   withRemoveTimestamps,   withUpdateTimestamps,   maybeAddCompilerTimestampRecord,-  isDepModified,   listModifiedDeps,   ) where @@ -33,7 +32,7 @@                                                       defaultSDistFlags,                                                       sdistCommand) import Distribution.Simple.Utils                     (debug, die,-                                                      findPackageDesc, warn)+                                                      tryFindPackageDesc, warn) import Distribution.System                           (Platform) import Distribution.Text                             (display) import Distribution.Verbosity                        (Verbosity, lessVerbose,@@ -215,7 +214,7 @@ allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath] allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do   pkg <- fmap (flattenPackageDescription)-         . readPackageDescription verbosity =<< findPackageDesc packageDir+         . readPackageDescription verbosity =<< tryFindPackageDesc packageDir    let file      = "cabal-sdist-list-sources"       flags     = defaultSDistFlags {

Distribution/Client/Setup.hs view

@@ -11,7 +11,7 @@ -- ----------------------------------------------------------------------------- module Distribution.Client.Setup-    ( globalCommand, GlobalFlags(..), globalRepos+    ( globalCommand, GlobalFlags(..), defaultGlobalFlags, globalRepos     , configureCommand, ConfigFlags(..), filterConfigureFlags     , configureExCommand, ConfigExFlags(..), defaultConfigExFlags                         , configureExOptions@@ -23,8 +23,10 @@     , upgradeCommand     , infoCommand, InfoFlags(..)     , fetchCommand, FetchFlags(..)+    , freezeCommand, FreezeFlags(..)     , getCommand, unpackCommand, GetFlags(..)     , checkCommand+    , formatCommand     , uploadCommand, UploadFlags(..)     , reportCommand, ReportFlags(..)     , runCommand@@ -32,6 +34,7 @@     , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)     , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)     , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)+    , execCommand, ExecFlags(..)      , parsePackageArgs     --TODO: stop exporting these:@@ -44,21 +47,24 @@ import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Dependency.Types-         ( PreSolver(..) )+         ( AllowNewer(..), PreSolver(..) ) import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets          ( UserConstraint, readUserConstraint ) +import Distribution.Simple.Compiler (PackageDB) import Distribution.Simple.Program          ( defaultProgramConfiguration )-import Distribution.Simple.Command hiding (boolOpt)+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import qualified Distribution.Simple.Command as Command import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup          ( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..)          , SDistFlags(..), HaddockFlags(..)+         , readPackageDbList, showPackageDbList          , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList-         , optionVerbosity, boolOpt, trueArg, falseArg )+         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg, optionNumJobs ) import Distribution.Simple.InstallDirs          ( PathTemplate, InstallDirs(sysconfdir)          , toPathTemplate, fromPathTemplate )@@ -73,7 +79,7 @@ import Distribution.ReadE          ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, (+++) )+         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) ) import Distribution.Verbosity          ( Verbosity, normal ) import Distribution.Simple.Utils@@ -108,7 +114,9 @@     globalCacheDir          :: Flag FilePath,     globalLocalRepos        :: [FilePath],     globalLogsDir           :: Flag FilePath,-    globalWorldFile         :: Flag FilePath+    globalWorldFile         :: Flag FilePath,+    globalRequireSandbox    :: Flag Bool,+    globalIgnoreSandbox     :: Flag Bool   }  defaultGlobalFlags :: GlobalFlags@@ -117,11 +125,13 @@     globalNumericVersion    = Flag False,     globalConfigFile        = mempty,     globalSandboxConfigFile = mempty,-    globalRemoteRepos       = [],+    globalRemoteRepos       = mempty,     globalCacheDir          = mempty,     globalLocalRepos        = mempty,     globalLogsDir           = mempty,-    globalWorldFile         = mempty+    globalWorldFile         = mempty,+    globalRequireSandbox    = Flag False,+    globalIgnoreSandbox     = Flag False   }  globalCommand :: CommandUI GlobalFlags@@ -139,9 +149,9 @@       ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"       ++ "Occasionally you need to update the list of available packages:\n"       ++ "  " ++ pname ++ " update\n",-    commandDefaultFlags = defaultGlobalFlags,+    commandDefaultFlags = mempty,     commandOptions      = \showOrParseArgs ->-      (case showOrParseArgs of ShowArgs -> take 4; ParseArgs -> id)+      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)       [option ['V'] ["version"]          "Print version information"          globalVersion (\v flags -> flags { globalVersion = v })@@ -163,6 +173,16 @@          globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })          (reqArgFlag "FILE") +      ,option [] ["require-sandbox"]+         "requiring the presence of a sandbox for sandbox-aware commands"+         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })+         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))++      ,option [] ["ignore-sandbox"]+         "Ignore any existing sandbox"+         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })+         trueArg+       ,option [] ["remote-repo"]          "The name and url for a remote repository"          globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })@@ -200,7 +220,9 @@     globalCacheDir          = mempty,     globalLocalRepos        = mempty,     globalLogsDir           = mempty,-    globalWorldFile         = mempty+    globalWorldFile         = mempty,+    globalRequireSandbox    = mempty,+    globalIgnoreSandbox     = mempty   }   mappend a b = GlobalFlags {     globalVersion           = combine globalVersion,@@ -211,7 +233,9 @@     globalCacheDir          = combine globalCacheDir,     globalLocalRepos        = combine globalLocalRepos,     globalLogsDir           = combine globalLogsDir,-    globalWorldFile         = combine globalWorldFile+    globalWorldFile         = combine globalWorldFile,+    globalRequireSandbox    = combine globalRequireSandbox,+    globalIgnoreSandbox     = combine globalIgnoreSandbox   }     where combine field = field a `mappend` field b @@ -241,24 +265,32 @@  filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags filterConfigureFlags flags cabalLibVersion-  | cabalLibVersion >= Version [1,18,0] [] = flags+  | cabalLibVersion >= Version [1,19,2] [] = flags_latest   | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10   | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0   | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0   | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0--  -- A no-op that silences the "pattern match is non-exhaustive" warning.-  | otherwise = flags+  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0+  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1+  | otherwise = flags_latest   where+    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.+    flags_latest = flags        { configConstraints = [] }++    -- Cabal < 1.19.2 doesn't know about '--exact-configuration'.+    flags_1_19_1 = flags_latest { 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        { configProgramPathExtra = []+    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = []                                 , configInstallDirs = configInstallDirs_1_18_0}     configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }-    -- Cabal < 1.14.0 doesn't know about --disable-benchmarks.+    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.     flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }-    -- Cabal < 1.10.0 doesn't know about --disable-tests.+    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.     flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }-    -- Cabal < 1.3.10 does not grok the constraints flag.+    -- Cabal < 1.3.10 does not grok the '--constraints' flag.     flags_1_3_10 = flags_1_10_0 { configConstraints = [] }  -- ------------------------------------------------------------@@ -271,18 +303,21 @@     configCabalVersion :: Flag Version,     configExConstraints:: [UserConstraint],     configPreferences  :: [Dependency],-    configSolver       :: Flag PreSolver+    configSolver       :: Flag PreSolver,+    configAllowNewer   :: Flag AllowNewer   }  defaultConfigExFlags :: ConfigExFlags-defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }+defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver+                              , configAllowNewer = Flag AllowNewerNone }  configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = configureCommand {     commandDefaultFlags = (mempty, defaultConfigExFlags),     commandOptions      = \showOrParseArgs ->-         liftOptions fst setFst (filter ((/="constraint") . optionName) $-                                 configureOptions   showOrParseArgs)+         liftOptions fst setFst+         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])+                  . optionName) $ configureOptions  showOrParseArgs)       ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)   }   where@@ -314,6 +349,14 @@               (map display))    , optionSolver configSolver (\v flags -> flags { configSolver = v })++  , option [] ["allow-newer"]+    "Ignore upper bounds in dependencies on some or all packages."+    configAllowNewer (\v flags -> flags { configAllowNewer = v})+    (optArg "PKGS"+     (fmap Flag allowNewerParser) (Flag AllowNewerAll)+     allowNewerPrinter)+   ]  instance Monoid ConfigExFlags where@@ -321,13 +364,15 @@     configCabalVersion = mempty,     configExConstraints= mempty,     configPreferences  = mempty,-    configSolver       = mempty+    configSolver       = mempty,+    configAllowNewer   = mempty   }   mappend a b = ConfigExFlags {     configCabalVersion = combine configCabalVersion,     configExConstraints= combine configExConstraints,     configPreferences  = combine configPreferences,-    configSolver       = combine configSolver+    configSolver       = combine configSolver,+    configAllowNewer   = combine configAllowNewer   }     where combine field = field a `mappend` field b @@ -340,20 +385,12 @@   deriving Eq  data BuildExFlags = BuildExFlags {-  buildNumJobs  :: Flag (Maybe Int),   buildOnly     :: Flag SkipAddSourceDepsCheck }  buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags] buildExOptions _showOrParseArgs =-  option "j" ["jobs"]-  "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)"-  buildNumJobs (\v flags -> flags { buildNumJobs = v })-  (optArg "NUM" (fmap Flag numJobsParser)-   (Flag Nothing)-   (map (Just . maybe "$ncpus" show) . flagToList))--  : option [] ["only"]+  option [] ["only"]   "Don't reinstall add-source dependencies (sandbox-only)"   buildOnly (\v flags -> flags { buildOnly = v })   (noArg (Flag SkipAddSourceDepsCheck))@@ -377,11 +414,9 @@  instance Monoid BuildExFlags where   mempty = BuildExFlags {-    buildNumJobs = mempty,     buildOnly    = mempty   }   mappend a b = BuildExFlags {-    buildNumJobs = combine buildNumJobs,     buildOnly    = combine buildOnly   }     where combine field = field a `mappend` field b@@ -390,39 +425,51 @@ -- * Test command -- ------------------------------------------------------------ -testCommand :: CommandUI (TestFlags, BuildExFlags)+testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags) testCommand = parent {-  commandDefaultFlags = (commandDefaultFlags parent, mempty),+  commandDefaultFlags = (commandDefaultFlags parent,+                         Cabal.defaultBuildFlags, mempty),   commandOptions      =-    \showOrParseArgs -> liftOptions fst setFst+    \showOrParseArgs -> liftOptions get1 set1                         (commandOptions parent showOrParseArgs)                         ++-                        liftOptions snd setSnd (buildExOptions showOrParseArgs)+                        liftOptions get2 set2+                        (Cabal.buildOptions progConf showOrParseArgs)+                        +++                        liftOptions get3 set3 (buildExOptions showOrParseArgs)   }   where-    setFst a (_,b) = (a,b)-    setSnd b (a,_) = (a,b)+    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)+    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)+    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) -    parent = Cabal.testCommand+    parent   = Cabal.testCommand+    progConf = defaultProgramConfiguration  -- ------------------------------------------------------------ -- * Bench command -- ------------------------------------------------------------ -benchmarkCommand :: CommandUI (BenchmarkFlags, BuildExFlags)+benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags) benchmarkCommand = parent {-  commandDefaultFlags = (commandDefaultFlags parent, mempty),+  commandDefaultFlags = (commandDefaultFlags parent,+                         Cabal.defaultBuildFlags, mempty),   commandOptions      =-    \showOrParseArgs -> liftOptions fst setFst+    \showOrParseArgs -> liftOptions get1 set1                         (commandOptions parent showOrParseArgs)                         ++-                        liftOptions snd setSnd (buildExOptions showOrParseArgs)+                        liftOptions get2 set2+                        (Cabal.buildOptions progConf showOrParseArgs)+                        +++                        liftOptions get3 set3 (buildExOptions showOrParseArgs)   }   where-    setFst a (_,b) = (a,b)-    setSnd b (a,_) = (a,b)+    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)+    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)+    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) -    parent = Cabal.benchmarkCommand+    parent   = Cabal.benchmarkCommand+    progConf = defaultProgramConfiguration  -- ------------------------------------------------------------ -- * Fetch command@@ -437,7 +484,6 @@       fetchReorderGoals     :: Flag Bool,       fetchIndependentGoals :: Flag Bool,       fetchShadowPkgs       :: Flag Bool,-      fetchStrongFlags      :: Flag Bool,       fetchVerbosity :: Flag Verbosity     } @@ -451,7 +497,6 @@     fetchReorderGoals     = Flag False,     fetchIndependentGoals = Flag False,     fetchShadowPkgs       = Flag False,-    fetchStrongFlags      = Flag False,     fetchVerbosity = toFlag normal    } @@ -493,11 +538,61 @@                          fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })                          fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })                          fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })-                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })    }  -- ------------------------------------------------------------+-- * Freeze command+-- ------------------------------------------------------------++data FreezeFlags = FreezeFlags {+      freezeDryRun           :: Flag Bool,+      freezeSolver           :: Flag PreSolver,+      freezeMaxBackjumps     :: Flag Int,+      freezeReorderGoals     :: Flag Bool,+      freezeIndependentGoals :: Flag Bool,+      freezeShadowPkgs       :: Flag Bool,+      freezeVerbosity        :: Flag Verbosity+    }++defaultFreezeFlags :: FreezeFlags+defaultFreezeFlags = FreezeFlags {+    freezeDryRun           = toFlag False,+    freezeSolver           = Flag defaultSolver,+    freezeMaxBackjumps     = Flag defaultMaxBackjumps,+    freezeReorderGoals     = Flag False,+    freezeIndependentGoals = Flag False,+    freezeShadowPkgs       = Flag False,+    freezeVerbosity        = toFlag normal+   }++freezeCommand :: CommandUI FreezeFlags+freezeCommand = CommandUI {+    commandName         = "freeze",+    commandSynopsis     = "Freeze dependencies.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "freeze",+    commandDefaultFlags = defaultFreezeFlags,+    commandOptions      = \ showOrParseArgs -> [+         optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })++       , option [] ["dry-run"]+           "Do not freeze anything, only print what would be frozen"+           freezeDryRun (\v flags -> flags { freezeDryRun = v })+           trueArg++       ] ++++       optionSolver      freezeSolver           (\v flags -> flags { freezeSolver           = v }) :+       optionSolverFlags showOrParseArgs+                         freezeMaxBackjumps     (\v flags -> flags { freezeMaxBackjumps     = v })+                         freezeReorderGoals     (\v flags -> flags { freezeReorderGoals     = v })+                         freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })+                         freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })++  }++-- ------------------------------------------------------------ -- * Other commands -- ------------------------------------------------------------ @@ -542,6 +637,16 @@     commandOptions      = \_ -> []   } +formatCommand  :: CommandUI (Flag Verbosity)+formatCommand = CommandUI {+    commandName         = "format",+    commandSynopsis     = "Reformat the .cabal file using the standard style.",+    commandDescription  = Nothing,+    commandUsage        = \pname -> "Usage: " ++ pname ++ " format [FILE]\n",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> []+  }+ runCommand :: CommandUI (BuildFlags, BuildExFlags) runCommand = CommandUI {     commandName         = "run",@@ -554,7 +659,7 @@     commandDefaultFlags = mempty,     commandOptions      =       \showOrParseArgs -> liftOptions fst setFst-                          (Cabal.buildOptions progConf showOrParseArgs)+                          (commandOptions parent showOrParseArgs)                           ++                           liftOptions snd setSnd                           (buildExOptions showOrParseArgs)@@ -563,7 +668,7 @@     setFst a (_,b) = (a,b)     setSnd b (a,_) = (a,b) -    progConf = defaultProgramConfiguration+    parent = Cabal.buildCommand defaultProgramConfiguration  -- ------------------------------------------------------------ -- * Report flags@@ -650,7 +755,7 @@        ++ "Alternatively, with -s it will\nget the code from the source "        ++ "repository specified by the package.\n",     commandUsage        = usagePackages "get",-    commandDefaultFlags = mempty,+    commandDefaultFlags = defaultGetFlags,     commandOptions      = \_ -> [         optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v }) @@ -683,7 +788,12 @@   }  instance Monoid GetFlags where-  mempty = defaultGetFlags+  mempty = GetFlags {+    getDestDir          = mempty,+    getPristine         = mempty,+    getSourceRepository = mempty,+    getVerbosity        = mempty+    }   mappend a b = GetFlags {     getDestDir          = combine getDestDir,     getPristine         = combine getPristine,@@ -697,16 +807,18 @@ -- ------------------------------------------------------------  data ListFlags = ListFlags {-    listInstalled :: Flag Bool,+    listInstalled    :: Flag Bool,     listSimpleOutput :: Flag Bool,-    listVerbosity :: Flag Verbosity+    listVerbosity    :: Flag Verbosity,+    listPackageDBs   :: [Maybe PackageDB]   }  defaultListFlags :: ListFlags defaultListFlags = ListFlags {-    listInstalled = Flag False,+    listInstalled    = Flag False,     listSimpleOutput = Flag False,-    listVerbosity = toFlag normal+    listVerbosity    = toFlag normal,+    listPackageDBs   = []   }  listCommand  :: CommandUI ListFlags@@ -729,15 +841,26 @@             listSimpleOutput (\v flags -> flags { listSimpleOutput = v })             trueArg +        , option "" ["package-db"]+          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."+          listPackageDBs (\v flags -> flags { listPackageDBs = v })+          (reqArg' "DB" readPackageDbList showPackageDbList)+         ]   }  instance Monoid ListFlags where-  mempty = defaultListFlags+  mempty = ListFlags {+    listInstalled    = mempty,+    listSimpleOutput = mempty,+    listVerbosity    = mempty,+    listPackageDBs   = mempty+    }   mappend a b = ListFlags {-    listInstalled = combine listInstalled,+    listInstalled    = combine listInstalled,     listSimpleOutput = combine listSimpleOutput,-    listVerbosity = combine listVerbosity+    listVerbosity    = combine listVerbosity,+    listPackageDBs   = combine listPackageDBs   }     where combine field = field a `mappend` field b @@ -746,12 +869,14 @@ -- ------------------------------------------------------------  data InfoFlags = InfoFlags {-    infoVerbosity :: Flag Verbosity+    infoVerbosity  :: Flag Verbosity,+    infoPackageDBs :: [Maybe PackageDB]   }  defaultInfoFlags :: InfoFlags defaultInfoFlags = InfoFlags {-    infoVerbosity = toFlag normal+    infoVerbosity  = toFlag normal,+    infoPackageDBs = []   }  infoCommand  :: CommandUI InfoFlags@@ -763,13 +888,23 @@     commandDefaultFlags = defaultInfoFlags,     commandOptions      = \_ -> [         optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })++        , option "" ["package-db"]+          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."+          infoPackageDBs (\v flags -> flags { infoPackageDBs = v })+          (reqArg' "DB" readPackageDbList showPackageDbList)+         ]   }  instance Monoid InfoFlags where-  mempty = defaultInfoFlags+  mempty = InfoFlags {+    infoVerbosity  = mempty,+    infoPackageDBs = mempty+    }   mappend a b = InfoFlags {-    infoVerbosity = combine infoVerbosity+    infoVerbosity  = combine infoVerbosity,+    infoPackageDBs = combine infoPackageDBs   }     where combine field = field a `mappend` field b @@ -787,7 +922,6 @@     installReorderGoals     :: Flag Bool,     installIndependentGoals :: Flag Bool,     installShadowPkgs       :: Flag Bool,-    installStrongFlags      :: Flag Bool,     installReinstall        :: Flag Bool,     installAvoidReinstalls  :: Flag Bool,     installOverrideReinstall :: Flag Bool,@@ -800,7 +934,8 @@     installBuildReports     :: Flag ReportLevel,     installSymlinkBinDir    :: Flag FilePath,     installOneShot          :: Flag Bool,-    installNumJobs          :: Flag (Maybe Int)+    installNumJobs          :: Flag (Maybe Int),+    installRunTests         :: Flag Bool   }  defaultInstallFlags :: InstallFlags@@ -812,7 +947,6 @@     installReorderGoals    = Flag False,     installIndependentGoals= Flag False,     installShadowPkgs      = Flag False,-    installStrongFlags     = Flag False,     installReinstall       = Flag False,     installAvoidReinstalls = Flag False,     installOverrideReinstall = Flag False,@@ -825,13 +959,35 @@     installBuildReports    = Flag NoReports,     installSymlinkBinDir   = mempty,     installOneShot         = Flag False,-    installNumJobs         = mempty+    installNumJobs         = mempty,+    installRunTests        = mempty   }   where     docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html") +allowNewerParser :: ReadE AllowNewer+allowNewerParser = ReadE $ \s ->+  case s of+    ""      -> Right AllowNewerNone+    "False" -> Right AllowNewerNone+    "True"  -> Right AllowNewerAll+    _       ->+      case readPToMaybe pkgsParser s of+        Just pkgs -> Right . AllowNewerSome $ pkgs+        Nothing   -> Left ("Cannot parse the list of packages: " ++ s)+  where+    pkgsParser = Parse.sepBy1 parse (Parse.char ',')++allowNewerPrinter :: Flag AllowNewer -> [Maybe String]+allowNewerPrinter (Flag AllowNewerNone)        = [Just "False"]+allowNewerPrinter (Flag AllowNewerAll)         = [Just "True"]+allowNewerPrinter (Flag (AllowNewerSome pkgs)) =+  [Just . intercalate "," . map display $ pkgs]+allowNewerPrinter NoFlag                       = []++ defaultMaxBackjumps :: Int-defaultMaxBackjumps = 2000+defaultMaxBackjumps = 200  defaultSolver :: PreSolver defaultSolver = Choose@@ -860,7 +1016,10 @@      ++ "    Constrained package version\n",   commandDefaultFlags = (mempty, mempty, mempty, mempty),   commandOptions      = \showOrParseArgs ->-       liftOptions get1 set1 (filter ((/="constraint") . optionName) $+       liftOptions get1 set1+       (filter ((`notElem` ["constraint", "dependency"+                           , "exact-configuration"])+                . optionName) $                               configureOptions   showOrParseArgs)     ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)     ++ liftOptions get3 set3 (installOptions     showOrParseArgs)@@ -879,10 +1038,10 @@                           | descr <- optionDescr opt] }     | opt <- commandOptions Cabal.haddockCommand showOrParseArgs     , let name = optionName opt-    , name `elem` ["hoogle", "html", "html-location",-                   "executables", "internal", "css",-                   "hyperlink-source", "hscolour-css",-                   "contents-location"]+    , name `elem` ["hoogle", "html", "html-location"+                  ,"executables", "tests", "benchmarks", "all", "internal", "css"+                  ,"hyperlink-source", "hscolour-css"+                  ,"contents-location"]     ]   where     fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a@@ -914,8 +1073,7 @@                         installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })                         installReorderGoals     (\v flags -> flags { installReorderGoals     = v })                         installIndependentGoals (\v flags -> flags { installIndependentGoals = v })-                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v })-                        installStrongFlags      (\v flags -> flags { installStrongFlags      = v }) +++                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v }) ++        [ option [] ["reinstall"]           "Install even if it means installing the same version again."@@ -981,12 +1139,14 @@           installOneShot (\v flags -> flags { installOneShot = v })           (yesNoOpt showOrParseArgs) -      , option "j" ["jobs"]-        "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."+      , option [] ["run-tests"]+          "Run package test suites during installation."+          installRunTests (\v flags -> flags { installRunTests = v })+          trueArg++      , optionNumJobs         installNumJobs (\v flags -> flags { installNumJobs = v })-        (optArg "NUM" (fmap Flag numJobsParser)-                      (Flag Nothing)-                      (map (Just . maybe "$ncpus" show) . flagToList))+       ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"                                         -- avoids           ParseArgs ->@@ -1010,7 +1170,6 @@     installReorderGoals    = mempty,     installIndependentGoals= mempty,     installShadowPkgs      = mempty,-    installStrongFlags     = mempty,     installOnly            = mempty,     installOnlyDeps        = mempty,     installRootCmd         = mempty,@@ -1019,7 +1178,8 @@     installBuildReports    = mempty,     installSymlinkBinDir   = mempty,     installOneShot         = mempty,-    installNumJobs         = mempty+    installNumJobs         = mempty,+    installRunTests        = mempty   }   mappend a b = InstallFlags {     installDocumentation   = combine installDocumentation,@@ -1033,7 +1193,6 @@     installReorderGoals    = combine installReorderGoals,     installIndependentGoals= combine installIndependentGoals,     installShadowPkgs      = combine installShadowPkgs,-    installStrongFlags     = combine installStrongFlags,     installOnly            = combine installOnly,     installOnlyDeps        = combine installOnlyDeps,     installRootCmd         = combine installRootCmd,@@ -1042,7 +1201,8 @@     installBuildReports    = combine installBuildReports,     installSymlinkBinDir   = combine installSymlinkBinDir,     installOneShot         = combine installOneShot,-    installNumJobs         = combine installNumJobs+    installNumJobs         = combine installNumJobs,+    installRunTests        = combine installRunTests   }     where combine field = field a `mappend` field b @@ -1173,7 +1333,9 @@       , option ['p'] ["package-name"]         "Name of the Cabal package to create."         IT.packageName (\v flags -> flags { IT.packageName = v })-        (reqArgFlag "PACKAGE")+        (reqArg "PACKAGE" (readP_to_E ("Cannot parse package name: "++)+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))        , option [] ["version"]         "Initial version of the package."@@ -1239,6 +1401,12 @@         (\v flags -> flags { IT.packageType = v })         (noArg (Flag IT.Executable)) +      , option [] ["main-is"]+        "Specify the main module."+        IT.mainIs+        (\v flags -> flags { IT.mainIs = v })+        (reqArgFlag "FILE")+       , option [] ["language"]         "Specify the default language."         IT.language@@ -1369,10 +1537,12 @@ }  instance Monoid Win32SelfUpgradeFlags where-  mempty = defaultWin32SelfUpgradeFlags+  mempty      = Win32SelfUpgradeFlags {+    win32SelfUpgradeVerbosity = mempty+    }   mappend a b = Win32SelfUpgradeFlags {     win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity-  }+    }     where combine field = field a `mappend` field b  -- ------------------------------------------------------------@@ -1440,21 +1610,43 @@     where combine field = field a `mappend` field b  -- --------------------------------------------------------------- * Shared options utils+-- * Exec Flags -- ------------------------------------------------------------ --- | Common parser for the @-j@ flag of @build@ and @install@.-numJobsParser :: ReadE (Maybe Int)-numJobsParser = ReadE $ \s ->-  case s of-    "$ncpus" -> Right Nothing-    _        -> case reads s of-      [(n, "")]-        | n < 1     -> Left "The number of jobs should be 1 or more."-        | n > 64    -> Left "You probably don't want that many jobs."-        | otherwise -> Right (Just n)-      _             -> Left "The jobs value should be a number or '$ncpus'"+data ExecFlags = ExecFlags {+  execVerbosity :: Flag Verbosity+} +defaultExecFlags :: ExecFlags+defaultExecFlags = ExecFlags {+  execVerbosity = toFlag normal+  }++execCommand :: CommandUI ExecFlags+execCommand = CommandUI {+  commandName         = "exec",+  commandSynopsis     = "Run a command with the cabal environment",+  commandDescription  = Nothing,+  commandUsage        = \pname ->+       "Usage: " ++ pname ++ " exec [FLAGS] COMMAND [-- [ARGS...]]\n\n"+    ++ "Flags for exec:",++  commandDefaultFlags = defaultExecFlags,+  commandOptions      = \_ ->+    [ optionVerbosity execVerbosity+      (\v flags -> flags { execVerbosity = v })+    ]+  }++instance Monoid ExecFlags where+  mempty = ExecFlags {+    execVerbosity = mempty+    }+  mappend a b = ExecFlags {+    execVerbosity = combine execVerbosity+    }+    where combine field = field a `mappend` field b+ -- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------@@ -1469,7 +1661,7 @@  yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b yesNoOpt ShowArgs sf lf = trueArg sf lf-yesNoOpt _        sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf+yesNoOpt _        sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf  optionSolver :: (flags -> Flag PreSolver)              -> (Flag PreSolver -> flags -> flags)@@ -1487,9 +1679,8 @@                   -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)                   -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)                   -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)-                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)                   -> [OptionField flags]-optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip getstrfl setstrfl =+optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip =   [ option [] ["max-backjumps"]       ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")       getmbj setmbj@@ -1510,11 +1701,7 @@   , option [] ["shadow-installed-packages"]       "If multiple package instances of the same version are installed, treat all but one as shadowed."       getsip setsip-      (yesNoOpt showOrParseArgs)-  , option [] ["strong-flags"]-      "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)."-      getstrfl setstrfl-      (yesNoOpt showOrParseArgs)+      trueArg   ]

Distribution/Client/SetupWrapper.hs view

@@ -26,7 +26,7 @@          ( Version(..), VersionRange, anyVersion          , intersectVersionRanges, orLaterVersion          , withinRange )-import Distribution.InstalledPackageInfo (installedPackageId, sourcePackageId)+import Distribution.InstalledPackageInfo (installedPackageId) import Distribution.Package          ( InstalledPackageId(..), PackageIdentifier(..),            PackageName(..), Package(..), packageName@@ -42,8 +42,9 @@ import Distribution.Compiler ( buildCompilerId ) import Distribution.Simple.Compiler          ( CompilerFlavor(GHC), Compiler(compilerId)-         , compilerVersion          , PackageDB(..), PackageDBStack )+import Distribution.Simple.PreProcess+         ( runSimplePreProcessor, ppUnlit ) import Distribution.Simple.Program          ( ProgramConfiguration, emptyProgramConfiguration          , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram )@@ -68,11 +69,12 @@ import Distribution.Simple.Setup          ( Flag(..) ) import Distribution.Simple.Utils-         ( die, debug, info, cabalVersion, findPackageDesc, comparing+         ( die, debug, info, cabalVersion, tryFindPackageDesc, comparing          , createDirectoryIfMissingVerbose, installExecutableFile-         , moreRecentFile, rewriteFile, intercalate )+         , copyFileVerbose, rewriteFile, intercalate ) import Distribution.Client.Utils-         ( inDir, tryCanonicalizePath )+         ( inDir, tryCanonicalizePath+         , existsAndIsMoreRecentThan, moreRecentFile ) import Distribution.System ( Platform(..), buildPlatform ) import Distribution.Text          ( display )@@ -81,16 +83,17 @@ import Distribution.Compat.Exception          ( catchIO ) -import System.Directory  ( doesFileExist )-import System.FilePath   ( (</>), (<.>) )-import System.IO         ( Handle, hPutStr )-import System.Exit       ( ExitCode(..), exitWith )-import System.Process    ( runProcess, waitForProcess )-import Control.Monad     ( when, unless )-import Data.List         ( foldl1' )-import Data.Maybe        ( fromMaybe, isJust )-import Data.Monoid       ( mempty )-import Data.Char         ( isSpace )+import System.Directory    ( doesFileExist )+import System.FilePath     ( (</>), (<.>) )+import System.IO           ( Handle, hPutStr )+import System.Exit         ( ExitCode(..), exitWith )+import System.Process      ( runProcess, waitForProcess )+import Control.Applicative ( (<$>), (<*>) )+import Control.Monad       ( when, unless )+import Data.List           ( foldl1' )+import Data.Maybe          ( fromMaybe, isJust )+import Data.Monoid         ( mempty )+import Data.Char           ( isSpace )  data SetupScriptOptions = SetupScriptOptions {     useCabalVersion          :: VersionRange,@@ -156,7 +159,7 @@   checkBuildType buildType'   setupMethod verbosity options' (packageId pkg) buildType' mkArgs   where-    getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options))+    getPkg = tryFindPackageDesc (fromMaybe "." (useWorkingDir options))          >>= readPackageDescription verbosity          >>= return . packageDescription @@ -212,15 +215,13 @@ externalSetupMethod verbosity options pkg bt mkargs = do   debug verbosity $ "Using external setup method with build-type " ++ show bt   createDirectoryIfMissingVerbose verbosity True setupDir-  (cabalLibVersion, options') <- cabalLibVersionToUse+  (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse   debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion-  setupHs <- updateSetupScript cabalLibVersion bt-  debug verbosity $ "Using " ++ setupHs ++ " as setup script."-  path <- case bt of-    -- TODO: Should we also cache the setup exe for the Make and Configure build-    -- types?-    Simple -> getCachedSetupExecutable options' cabalLibVersion setupHs-    _      -> compileSetupExecutable options' cabalLibVersion setupHs False+  path <- if useCachedSetupExecutable+          then getCachedSetupExecutable options'+               cabalLibVersion mCabalLibInstalledPkgId+          else compileSetupExecutable   options'+               cabalLibVersion mCabalLibInstalledPkgId False   invokeSetupScript options' path (mkargs cabalLibVersion)    where@@ -228,8 +229,12 @@                        []  -> "."                        dir -> dir   setupDir         = workingDir </> useDistPref options </> "setup"-  setupVersionFile = setupDir </> "setup" <.> "version"+  setupVersionFile = setupDir   </> "setup" <.> "version"+  setupHs          = setupDir   </> "setup" <.> "hs"+  setupProgFile    = setupDir   </> "setup" <.> exeExtension +  useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)+   maybeGetInstalledPackages :: SetupScriptOptions -> Compiler                                -> ProgramConfiguration -> IO PackageIndex   maybeGetInstalledPackages options' comp conf =@@ -238,34 +243,98 @@       Nothing    -> getInstalledPackages verbosity                     comp (usePackageDB options') conf -  cabalLibVersionToUse :: IO (Version, SetupScriptOptions)+  cabalLibVersionToUse :: IO (Version, (Maybe InstalledPackageId)+                             ,SetupScriptOptions)   cabalLibVersionToUse = do-    savedVersion <- savedCabalVersion-    case savedVersion of+    savedVer <- savedVersion+    case savedVer of       Just version | version `withinRange` useCabalVersion options-        -> return (version, options)-      _ -> do (comp, conf, options') <- configureCompiler options-              version <- installedCabalVersion options' comp conf-              writeFile setupVersionFile (show version ++ "\n")-              return (version, options')+        -> do updateSetupScript version bt+              -- Does the previously compiled setup executable still exist and+              -- is it up-to date?+              useExisting <- canUseExistingSetup version+              if useExisting+                then return (version, Nothing, options)+                else installedVersion+      _ -> installedVersion+    where+      -- This check duplicates the checks in 'getCachedSetupExecutable' /+      -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice+      -- because the selected Cabal version may change as a result of this+      -- check.+      canUseExistingSetup :: Version -> IO Bool+      canUseExistingSetup version =+        if useCachedSetupExecutable+        then do+          (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version+          doesFileExist cachedSetupProgFile+        else+          (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs+               <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile -  savedCabalVersion = do-    versionString <- readFile setupVersionFile `catchIO` \_ -> return ""-    case reads versionString of-      [(version,s)] | all isSpace s -> return (Just version)-      _                             -> return Nothing+      installedVersion :: IO (Version, Maybe InstalledPackageId+                             ,SetupScriptOptions)+      installedVersion = do+        (comp,    conf,    options')  <- configureCompiler options+        (version, mipkgid, options'') <- installedCabalVersion options' comp conf+        updateSetupScript version bt+        writeFile setupVersionFile (show version ++ "\n")+        return (version, mipkgid, options'') -  installedCabalVersion :: SetupScriptOptions -> Compiler-                        -> ProgramConfiguration -> IO Version-  installedCabalVersion options' comp conf = do-    index <- maybeGetInstalledPackages options' comp conf-    let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options')+      savedVersion :: IO (Maybe Version)+      savedVersion = do+        versionString <- readFile setupVersionFile `catchIO` \_ -> return ""+        case reads versionString of+          [(version,s)] | all isSpace s -> return (Just version)+          _                             -> return Nothing++  -- | Update a Setup.hs script, creating it if necessary.+  updateSetupScript :: Version -> BuildType -> IO ()+  updateSetupScript _ Custom = do+    useHs  <- doesFileExist customSetupHs+    useLhs <- doesFileExist customSetupLhs+    unless (useHs || useLhs) $ die+      "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."+    let src = (if useHs then customSetupHs else customSetupLhs)+    srcNewer <- src `moreRecentFile` setupHs+    when srcNewer $ if useHs+                    then copyFileVerbose verbosity src setupHs+                    else runSimplePreProcessor ppUnlit src setupHs verbosity+    where+      customSetupHs   = workingDir </> "Setup.hs"+      customSetupLhs  = workingDir </> "Setup.lhs"++  updateSetupScript cabalLibVersion _ =+    rewriteFile setupHs (buildTypeScript cabalLibVersion)++  buildTypeScript :: Version -> String+  buildTypeScript cabalLibVersion = case bt of+    Simple    -> "import Distribution.Simple; main = defaultMain\n"+    Configure -> "import Distribution.Simple; main = defaultMainWithHooks "+              ++ if cabalLibVersion >= Version [1,3,10] []+                   then "autoconfUserHooks\n"+                   else "defaultUserHooks\n"+    Make      -> "import Distribution.Make; main = defaultMain\n"+    Custom             -> error "buildTypeScript Custom"+    UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"++  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')+        options''  = options' { usePackageIndex = Just index }     case PackageIndex.lookupDependency index cabalDep of       []   -> die $ "The package '" ++ display (packageName pkg)                  ++ "' requires Cabal library version "                  ++ display (useCabalVersion options)                  ++ " but no suitable version is installed."-      pkgs -> return $ bestVersion id (map fst pkgs)+      pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs+              in return (packageVersion ipkginfo+                        ,Just . installedPackageId $ ipkginfo, options'')    bestVersion :: (a -> Version) -> [a] -> a   bestVersion f = firstMaximumBy (comparing (preference . f))@@ -297,23 +366,6 @@                                _       -> False           latestVersion    = version -  -- TODO: This function looks a lot like @installedCabalVersion@ - can the-  -- duplication be removed?-  installedCabalPkgId :: SetupScriptOptions -> Compiler -> ProgramConfiguration-                         -> Version -> IO (Maybe InstalledPackageId)-  installedCabalPkgId _ _ _ _ | packageName pkg == PackageName "Cabal" =-    return Nothing-  installedCabalPkgId options' compiler conf cabalLibVersion = do-    index <- maybeGetInstalledPackages options' compiler conf-    let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion-    case PackageIndex.lookupSourcePackageId index cabalPkgid of-      []           -> die $ "The package '" ++ display (packageName pkg)-                      ++ "' requires Cabal library version "-                      ++ display (cabalLibVersion)-                      ++ " but no suitable version is installed."-      iPkgInfos   -> return . Just . installedPackageId-                     . bestVersion (pkgVersion . sourcePackageId) $ iPkgInfos-   configureCompiler :: SetupScriptOptions                     -> IO (Compiler, ProgramConfiguration, SetupScriptOptions)   configureCompiler options' = do@@ -330,107 +382,90 @@                                    usePackageIndex  = Just index,                                    useProgramConfig = conf }) -  -- | Decide which Setup.hs script to use, creating it if necessary.-  ---  updateSetupScript :: Version -> BuildType -> IO FilePath-  updateSetupScript _ Custom = do-    useHs  <- doesFileExist setupHs-    useLhs <- doesFileExist setupLhs-    unless (useHs || useLhs) $ die-      "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."-    return (if useHs then setupHs else setupLhs)-    where-      setupHs  = workingDir </> "Setup.hs"-      setupLhs = workingDir </> "Setup.lhs"--  updateSetupScript cabalLibVersion _ = do-    rewriteFile setupHs (buildTypeScript cabalLibVersion)-    return setupHs-    where-      setupHs  = setupDir </> "setup.hs"--  buildTypeScript :: Version -> String-  buildTypeScript cabalLibVersion = case bt of-    Simple    -> "import Distribution.Simple; main = defaultMain\n"-    Configure -> "import Distribution.Simple; main = defaultMainWithHooks "-              ++ if cabalLibVersion >= Version [1,3,10] []-                   then "autoconfUserHooks\n"-                   else "defaultUserHooks\n"-    Make      -> "import Distribution.Make; main = defaultMain\n"-    Custom             -> error "buildTypeScript Custom"-    UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"+  -- | Path to the setup exe cache directory and path to the cached setup+  -- executable.+  cachedSetupDirAndProg :: SetupScriptOptions -> Version+                        -> IO (FilePath, FilePath)+  cachedSetupDirAndProg options' cabalLibVersion = do+    cabalDir <- defaultCabalDir+    let setupCacheDir       = cabalDir </> "setup-exe-cache"+        cachedSetupProgFile = setupCacheDir+                              </> ("setup-" ++ buildTypeString ++ "-"+                                   ++ cabalVersionString ++ "-"+                                   ++ platformString ++ "-"+                                   ++ compilerVersionString)+                              <.> exeExtension+    return (setupCacheDir, cachedSetupProgFile)+      where+        buildTypeString       = show bt+        cabalVersionString    = "Cabal-" ++ (display cabalLibVersion)+        compilerVersionString = display $+                                fromMaybe buildCompilerId+                                (fmap compilerId . useCompiler $ options')+        platformString        = display $+                                fromMaybe buildPlatform (usePlatform options')    -- | Look up the setup executable in the cache; update the cache if the setup   -- executable is not found.-  getCachedSetupExecutable :: SetupScriptOptions -> Version -> FilePath+  getCachedSetupExecutable :: SetupScriptOptions+                           -> Version -> Maybe InstalledPackageId                            -> IO FilePath-  getCachedSetupExecutable options' cabalLibVersion setupHsFile = do-    cabalDir <- defaultCabalDir-    let setupCacheDir = cabalDir </> "setup-exe-cache"-    let setupProgFile = setupCacheDir-                        </> ("setup-" ++ cabalVersionString ++ "-"-                             ++ platformString ++ "-"-                             ++ compilerVersionString)-                        <.> exeExtension-    setupProgFileExists <- doesFileExist setupProgFile-    if setupProgFileExists+  getCachedSetupExecutable options' cabalLibVersion+                           maybeCabalLibInstalledPkgId = do+    (setupCacheDir, cachedSetupProgFile) <-+      cachedSetupDirAndProg options' cabalLibVersion+    cachedSetupExists <- doesFileExist cachedSetupProgFile+    if cachedSetupExists       then debug verbosity $-           "Found cached setup executable: " ++ setupProgFile+           "Found cached setup executable: " ++ cachedSetupProgFile       else criticalSection' $ do         -- The cache may have been populated while we were waiting.-        setupProgFileExists' <- doesFileExist setupProgFile-        if setupProgFileExists'+        cachedSetupExists' <- doesFileExist cachedSetupProgFile+        if cachedSetupExists'           then debug verbosity $-               "Found cached setup executable: " ++ setupProgFile+               "Found cached setup executable: " ++ cachedSetupProgFile           else do           debug verbosity $ "Setup executable not found in the cache."-          src <- compileSetupExecutable options' cabalLibVersion setupHsFile True+          src <- compileSetupExecutable options'+                 cabalLibVersion maybeCabalLibInstalledPkgId True           createDirectoryIfMissingVerbose verbosity True setupCacheDir-          installExecutableFile verbosity src setupProgFile-    return setupProgFile+          installExecutableFile verbosity src cachedSetupProgFile+    return cachedSetupProgFile       where-        cabalVersionString    = "Cabal-" ++ (display cabalLibVersion)-        compilerVersionString = display $-                                fromMaybe buildCompilerId-                                (fmap compilerId . useCompiler $ options')-        platformString        = display $-                                fromMaybe buildPlatform (usePlatform options')         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.   ---  compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> Bool+  compileSetupExecutable :: SetupScriptOptions+                         -> Version -> Maybe InstalledPackageId -> Bool                          -> IO FilePath-  compileSetupExecutable options' cabalLibVersion setupHsFile forceCompile = do-    setupHsNewer      <- setupHsFile      `moreRecentFile` setupProgFile+  compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId+                         forceCompile = do+    setupHsNewer      <- setupHs          `moreRecentFile` setupProgFile     cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile     let outOfDate = setupHsNewer || cabalVersionNewer     when (outOfDate || forceCompile) $ do       debug verbosity "Setup executable needs to be updated, compiling..."       (compiler, conf, options'') <- configureCompiler options'       let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion-      maybeCabalInstalledPkgId <- installedCabalPkgId options'' compiler conf-                                  cabalLibVersion       let ghcOptions = mempty {               ghcOptVerbosity       = Flag verbosity             , ghcOptMode            = Flag GhcModeMake-            , ghcOptInputFiles      = [setupHsFile]+            , ghcOptInputFiles      = [setupHs]             , ghcOptOutputFile      = Flag setupProgFile             , ghcOptObjDir          = Flag setupDir             , ghcOptHiDir           = Flag setupDir             , ghcOptSourcePathClear = Flag True-            , ghcOptSourcePath      = case bt of-                                      Custom -> [workingDir]-                                      _      -> []+            , ghcOptSourcePath      = [workingDir]             , ghcOptPackageDBs      = usePackageDB options''-            , ghcOptPackages        =-              maybe []-              (\cabalInstalledPkgId -> [(cabalInstalledPkgId, cabalPkgid)])-              maybeCabalInstalledPkgId+            , ghcOptPackages        = maybe []+                                      (\ipkgid -> [(ipkgid, cabalPkgid)])+                                      maybeCabalLibInstalledPkgId+            , ghcOptExtra           = ["-threaded"]             }-      let ghcCmdLine = renderGhcOptions (compilerVersion compiler) ghcOptions+      let ghcCmdLine = renderGhcOptions compiler ghcOptions       case useLoggingHandle options of         Nothing          -> runDbProgram verbosity ghcProgram conf ghcCmdLine @@ -439,8 +474,6 @@                                          conf ghcCmdLine                                hPutStr logHandle output     return setupProgFile-    where-      setupProgFile = setupDir </> "setup" <.> exeExtension    invokeSetupScript :: SetupScriptOptions -> FilePath -> [String] -> IO ()   invokeSetupScript options' path args = do

Distribution/Client/SrcDist.hs view

@@ -117,7 +117,7 @@         zipfile   = targetPref </> dir <.> "zip"     (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb -    -- zip has an annoying habbit of updating the target rather than creating+    -- zip has an annoying habit of updating the target rather than creating     -- it from scratch. While that might sound like an optimisation, it doesn't     -- remove files already in the archive that are no longer present in the     -- uncompressed tree.

Distribution/Client/Tar.hs view

@@ -71,7 +71,8 @@ import Data.Bits     (Bits, shiftL, testBit) import Data.List     (foldl') import Numeric       (readOct, showOct)-import Control.Monad (MonadPlus(mplus), when)+import Control.Applicative (Applicative(..))+import Control.Monad (MonadPlus(mplus), when, ap, liftM) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8@@ -94,6 +95,7 @@ import System.Posix.Types          ( FileMode ) import Distribution.Client.Compat.Time+         ( EpochTime, getModTime ) import System.IO          ( IOMode(ReadMode), openBinaryFile, hFileSize ) import System.IO.Unsafe (unsafeInterleaveIO)@@ -228,7 +230,7 @@      V7Format       -- | The \"USTAR\" format is an extension of the classic V7 format. It was-     -- later standardised by POSIX. It has some restructions but is the most+     -- later standardised by POSIX. It has some restrictions but is the most      -- portable format.      --    | UstarFormat@@ -253,7 +255,7 @@ directoryPermissions  = 0o0755  isExecutable :: Permissions -> Bool-isExecutable p = testBit p 0 || testBit p 6 -- user or other exectuable+isExecutable p = testBit p 0 || testBit p 6 -- user or other executable  -- | An 'Entry' with all default values except for the file name and type. It -- uses the portable USTAR/POSIX format (see 'UstarHeader').@@ -317,7 +319,7 @@ -- -- So it's understandable but rather annoying. ----- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective+-- * Tar paths use POSIX format (ie @\'/\'@ directory separators), irrespective --   of the local path conventions. -- -- * The directory separator between the prefix and name is /not/ stored.@@ -366,7 +368,7 @@ -- | Take a sanitized path, split on directory separators and try to pack it -- into the 155 + 100 tar file name format. ----- The stragey is this: take the name-directory components in reverse order+-- The strategy is this: take the name-directory components in reverse order -- and try to fit as many components into the 100 long name area as possible. -- If all the remaining components fit in the 155 name area then we win. --@@ -482,7 +484,7 @@ -- * file names are valid -- -- These checks are from the perspective of the current OS. That means we check--- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive+-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on Unix. For archive -- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the -- link target. A failure in any entry terminates the sequence of entries with -- an error.@@ -675,6 +677,13 @@ 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+    (<*>)         = ap  instance Monad Partial where     return        = Ok

Distribution/Client/Targets.hs view

@@ -70,7 +70,7 @@          ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase )+         ( die, warn, intercalate, tryFindPackageDesc, fromUTF8, lowercase )  import Data.List          ( find, nub )@@ -177,7 +177,6 @@    | SpecificSourcePackage pkg   deriving Show - pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName pkgSpecifierTarget (NamedPackage name _)       = name pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg@@ -423,7 +422,7 @@      UserTargetLocalCabalFile file -> do       let dir = takeDirectory file-      _   <- findPackageDesc dir -- just as a check+      _   <- tryFindPackageDesc dir -- just as a check       return [ PackageTargetLocation (LocalUnpackedPackage dir) ]      UserTargetLocalTarball tarballFile ->@@ -469,7 +468,7 @@     PackageTargetLocation location -> case location of        LocalUnpackedPackage dir -> do-        pkg <- readPackageDescription verbosity =<< findPackageDesc dir+        pkg <- readPackageDescription verbosity =<< tryFindPackageDesc dir         return $ PackageTargetLocation $                    SourcePackage {                      packageInfoId        = packageId pkg,

Distribution/Client/Types.hs view

@@ -91,7 +91,28 @@ instance PackageFixedDeps ConfiguredPackage where   depends (ConfiguredPackage _ _ _ deps) = deps +-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be+-- installed already, hence itself ready to be installed.+data ReadyPackage = ReadyPackage+       SourcePackage           -- see 'ConfiguredPackage'.+       FlagAssignment          --+       [OptionalStanza]        --+       [InstalledPackageInfo]  -- Installed dependencies.+  deriving Show +instance Package ReadyPackage where+  packageId (ReadyPackage pkg _ _ _) = packageId pkg++instance PackageFixedDeps ReadyPackage where+  depends (ReadyPackage _ _ _ deps) = map packageId deps++-- | Sometimes we need to convert a 'ReadyPackage' back to a+-- 'ConfiguredPackage'. For example, a failed 'PlanPackage' can be *either*+-- Ready or Configured.+readyPackageToConfiguredPackage :: ReadyPackage -> ConfiguredPackage+readyPackageToConfiguredPackage (ReadyPackage srcpkg flags stanzas deps) =+  ConfiguredPackage srcpkg flags stanzas (map packageId deps)+ -- | A package description along with the location of the package sources. -- data SourcePackage = SourcePackage {@@ -188,6 +209,7 @@                   | TestsFailed     SomeException                   | InstallFailed   SomeException data BuildSuccess = BuildOk         DocsResult TestsResult+                                    (Maybe InstalledPackageInfo)  data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk data TestsResult = TestsNotTried | TestsOk

Distribution/Client/Upload.hs view

@@ -3,6 +3,9 @@  module Distribution.Client.Upload (check, upload, report) where +import qualified Data.ByteString.Lazy.Char8 as B (concat, length, pack, readFile, unpack)+import           Data.ByteString.Lazy.Char8 (ByteString)+ import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..)) import Distribution.Client.HttpUtils (isOldHackageURI, cabalBrowse) @@ -15,16 +18,17 @@ 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) import Numeric          (showHex)-import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho-                        ,openBinaryFile, IOMode(ReadMode), hGetContents)+import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho) import Control.Exception (bracket) import System.Random    (randomRIO) import System.FilePath  ((</>), takeExtension, takeFileName)@@ -49,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@@ -75,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@@ -96,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@@ -118,31 +137,31 @@                      case findHeader HdrContentType resp of                        Just contenttype                          | takeWhile (/= ';') contenttype == "text/plain"-                         -> notice verbosity $ rspBody resp-                       _ -> debug verbosity $ rspBody resp+                         -> notice verbosity $ B.unpack $ rspBody resp+                       _ -> debug verbosity $ B.unpack $ rspBody resp -mkRequest :: URI -> FilePath -> IO (Request String)+mkRequest :: URI -> FilePath -> IO (Request ByteString) mkRequest uri path =      do pkg <- readBinaryFile path        boundary <- genBoundary-       let body = printMultiPart boundary (mkFormData path pkg)+       let body = printMultiPart (B.pack boundary) (mkFormData path pkg)        return $ Request {                          rqURI = uri,                          rqMethod = POST,                          rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),-                                      Header HdrContentLength (show (length body)),+                                      Header HdrContentLength (show (B.length body)),                                       Header HdrAccept ("text/plain")],                          rqBody = body                         } -readBinaryFile :: FilePath -> IO String-readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents+readBinaryFile :: FilePath -> IO ByteString+readBinaryFile = B.readFile  genBoundary :: IO String genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer                  return $ showHex i "" -mkFormData :: FilePath -> String -> [BodyPart]+mkFormData :: FilePath -> ByteString -> [BodyPart] mkFormData path pkg =   -- yes, web browsers are that stupid (re quoting)   [BodyPart [Header hdrContentDisposition $@@ -155,14 +174,17 @@  -- * Multipart, partly stolen from the cgi package. -data BodyPart = BodyPart [Header] String+data BodyPart = BodyPart [Header] ByteString -printMultiPart :: String -> [BodyPart] -> String-printMultiPart boundary xs = -    concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf+printMultiPart :: ByteString -> [BodyPart] -> ByteString+printMultiPart boundary xs =+    B.concat $ map (printBodyPart boundary) xs ++ [crlf, dd, boundary, dd, crlf] -printBodyPart :: String -> BodyPart -> String-printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c+printBodyPart :: ByteString -> BodyPart -> ByteString+printBodyPart boundary (BodyPart hs c) = B.concat $ [crlf, dd, boundary, crlf] ++ map (B.pack . show) hs ++ [crlf, c] -crlf :: String-crlf = "\r\n"+crlf :: ByteString+crlf = B.pack "\r\n"++dd :: ByteString+dd = B.pack "--"

Distribution/Client/Utils.hs view

@@ -2,14 +2,17 @@  module Distribution.Client.Utils ( MergeResult(..)                                  , mergeBy, duplicates, duplicatesBy-                                 , inDir, numberOfProcessors+                                 , inDir, determineNumJobs, numberOfProcessors                                  , removeExistingFile                                  , makeAbsoluteToCwd, filePathToByteString                                  , byteStringToFilePath, tryCanonicalizePath-                                 , canonicalizePathNoThrow )+                                 , canonicalizePathNoThrow+                                 , moreRecentFile, existsAndIsMoreRecentThan )        where -import Distribution.Compat.Exception ( catchIO )+import Distribution.Compat.Exception   ( catchIO )+import Distribution.Client.Compat.Time ( getModTime )+import Distribution.Simple.Setup       ( Flag(..) ) import qualified Data.ByteString.Lazy as BS import Control.Monad          ( when )@@ -32,8 +35,10 @@ import System.IO.Unsafe ( unsafePerformIO )  #if defined(mingw32_HOST_OS)+import Prelude hiding (ioError) import Control.Monad (liftM2, unless) import System.Directory (doesDirectoryExist)+import System.IO.Error (ioError, mkIOError, doesNotExistErrorType) #endif  -- | Generic merging utility. For sorted input lists this is a full outer join.@@ -88,6 +93,14 @@ numberOfProcessors :: Int numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors +-- | Determine the number of jobs to use given the value of the '-j' flag.+determineNumJobs :: Flag (Maybe Int) -> Int+determineNumJobs numJobsFlag =+  case numJobsFlag of+    NoFlag        -> 1+    Flag Nothing  -> numberOfProcessors+    Flag (Just n) -> n+ -- | Given a relative path, make it absolute relative to the current -- directory. Absolute paths are returned unmodified. makeAbsoluteToCwd :: FilePath -> IO FilePath@@ -139,8 +152,8 @@ #if defined(mingw32_HOST_OS)   exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret)   unless exists $-    error $ ret ++ ": canonicalizePath: does not exist "-                ++ "(No such file or directory)"+    ioError $ mkIOError doesNotExistErrorType "canonicalizePath"+                        Nothing (Just ret) #endif   return ret @@ -149,3 +162,26 @@ canonicalizePathNoThrow :: FilePath -> IO FilePath canonicalizePathNoThrow path = do   canonicalizePath path `catchIO` (\_ -> return path)++--------------------+-- Modification time++-- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead+-- of getModificationTime for higher precision. We can't merge the two because+-- Distribution.Client.Time uses MIN_VERSION macros.+moreRecentFile :: FilePath -> FilePath -> IO Bool+moreRecentFile a b = do+  exists <- doesFileExist b+  if not exists+    then return True+    else do tb <- getModTime b+            ta <- getModTime a+            return (ta > tb)++-- | Like 'moreRecentFile', but also checks that the first file exists.+existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool+existsAndIsMoreRecentThan a b = do+  exists <- doesFileExist a+  if not exists+    then return False+    else a `moreRecentFile` b

Distribution/Client/Win32SelfUpgrade.hs view

@@ -25,7 +25,7 @@ -- -- * Move our own exe file to a new name -- * Copy a new exe file to the previous name--- * Run the new exe file, passing our own pid and new path+-- * Run the new exe file, passing our own PID and new path -- * Wait for the new process to start -- * Close the new exe file -- * Exit old process@@ -61,7 +61,7 @@ -- that the nested action can replace our own exe file. -- -- We require that the new process accepts a command line invocation that--- calls 'deleteOldExeFile', passing in the pid and exe file.+-- calls 'deleteOldExeFile', passing in the PID and exe file. -- possibleSelfUpgrade :: Verbosity                     -> [FilePath]@@ -87,7 +87,7 @@ -- old and new processes. We need to synchronise to make sure that the old -- process has not yet terminated by the time the new one starts up and looks -- for the old process. Otherwise the old one might have already terminated--- and we could not wait on it terminating reliably (eg the pid might get+-- and we could not wait on it terminating reliably (eg the PID might get -- re-used). -- syncEventName :: String@@ -131,7 +131,7 @@  -- | Assuming we're now in the new child process, we've been asked by the old -- process to wait for it to terminate and then we can remove the old exe file--- that it renamted itself to.+-- that it renamed itself to. -- deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () deleteOldExeFile verbosity oldPID tmpPath = do

Main.hs view

@@ -22,8 +22,10 @@          , InstallFlags(..), defaultInstallFlags          , installCommand, upgradeCommand          , FetchFlags(..), fetchCommand+         , FreezeFlags(..), freezeCommand          , GetFlags(..), getCommand, unpackCommand          , checkCommand+         , formatCommand          , updateCommand          , ListFlags(..), listCommand          , InfoFlags(..), infoCommand@@ -34,10 +36,11 @@          , SDistFlags(..), SDistExFlags(..), sdistCommand          , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand          , SandboxFlags(..), sandboxCommand+         , ExecFlags(..), execCommand          , reportCommand          ) import Distribution.Simple.Setup-         ( HaddockFlags(..), haddockCommand+         ( HaddockFlags(..), haddockCommand, defaultHaddockFlags          , HscolourFlags(..), hscolourCommand          , ReplFlags(..), replCommand          , CopyFlags(..), copyCommand@@ -61,6 +64,7 @@ import Distribution.Client.Configure          (configure) import Distribution.Client.Update             (update) import Distribution.Client.Fetch              (fetch)+import Distribution.Client.Freeze             (freeze) import Distribution.Client.Check as Check     (check) --import Distribution.Client.Clean            (clean) import Distribution.Client.Upload as Upload   (upload, check, report)@@ -74,6 +78,7 @@                                               ,sandboxListSources                                               ,sandboxHcPkg                                               ,dumpPackageEnvironment+                                              ,withSandboxBinDirOnSearchPath                                                ,getSandboxConfigFilePath                                               ,loadConfigOrSandboxConfig@@ -84,19 +89,29 @@                                               ,maybeReinstallAddSourceDeps                                               ,tryGetIndexFilePath                                               ,sandboxBuildDir+                                              ,updateSandboxConfigFileFlag                                                ,configCompilerAux'                                               ,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+                                              ,existsAndIsMoreRecentThan)  import Distribution.PackageDescription          ( Executable(..) )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.PackageDescription.PrettyPrint+         ( writeGenericPackageDescription )+import Distribution.Simple.Build+         ( startInterpreter ) import Distribution.Simple.Command          ( CommandParse(..), CommandUI(..), Command          , commandsRun, commandAddAction, hiddenCommand )@@ -107,10 +122,14 @@          , ConfigStateFileErrorType(..), localBuildInfoFile          , getPersistBuildConfig, tryGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Program (defaultProgramConfiguration)+import Distribution.Simple.GHC (ghcGlobalPackageDB)+import Distribution.Simple.Program (defaultProgramConfiguration, lookupProgram, ghcProgram)+import Distribution.Simple.Program.Run (getEffectiveEnvironment) import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils-         ( cabalVersion, die, notice, info, moreRecentFile, topHandler )+         ( cabalVersion, debug, die, notice, info, topHandler+         , findPackageDesc, tryFindPackageDesc , rawSystemExit+         , rawSystemExitWithEnv ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity@@ -124,7 +143,7 @@ import System.FilePath          (splitExtension, takeExtension) import System.IO                (BufferMode(LineBuffering),                                  hSetBuffering, stdout)-import System.Directory         (doesFileExist)+import System.Directory         (doesFileExist, getCurrentDirectory) import Data.List                (intercalate) import Data.Monoid              (Monoid(..)) import Control.Monad            (when, unless)@@ -144,14 +163,18 @@     CommandHelp   help                 -> printGlobalHelp help     CommandList   opts                 -> printOptionsList opts     CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (globalflags, commandParse)  ->+    CommandReadyToGo (globalFlags, commandParse)  ->       case commandParse of-        _ | fromFlag (globalVersion globalflags)        -> printVersion-          | fromFlag (globalNumericVersion globalflags) -> printNumericVersion+        _ | fromFlagOrDefault False (globalVersion globalFlags)+            -> printVersion+          | fromFlagOrDefault False (globalNumericVersion globalFlags)+            -> printNumericVersion         CommandHelp     help           -> printCommandHelp help         CommandList     opts           -> printOptionsList opts         CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> action globalflags+        CommandReadyToGo action        -> do+          globalFlags' <- updateSandboxConfigFileFlag globalFlags+          action globalFlags'    where     printCommandHelp help = do@@ -182,6 +205,7 @@       ,listCommand            `commandAddAction` listAction       ,infoCommand            `commandAddAction` infoAction       ,fetchCommand           `commandAddAction` fetchAction+      ,freezeCommand          `commandAddAction` freezeAction       ,getCommand             `commandAddAction` getAction       ,hiddenCommand $        unpackCommand          `commandAddAction` unpackAction@@ -196,10 +220,10 @@       ,replCommand defaultProgramConfiguration                               `commandAddAction` replAction       ,sandboxCommand         `commandAddAction` sandboxAction+      ,haddockCommand         `commandAddAction` haddockAction+      ,execCommand            `commandAddAction` execAction       ,wrapperAction copyCommand                      copyVerbosity     copyDistPref-      ,wrapperAction haddockCommand-                     haddockVerbosity  haddockDistPref       ,wrapperAction cleanCommand                      cleanVerbosity    cleanDistPref       ,wrapperAction hscolourCommand@@ -209,6 +233,8 @@       ,testCommand            `commandAddAction` testAction       ,benchmarkCommand       `commandAddAction` benchmarkAction       ,hiddenCommand $+       formatCommand          `commandAddAction` formatAction+      ,hiddenCommand $        upgradeCommand         `commandAddAction` upgradeAction       ,hiddenCommand $        win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction@@ -253,6 +279,9 @@    whenUsingSandbox useSandbox $ \sandboxDir -> do     initPackageDBIfNeeded verbosity configFlags'' comp conf+    -- NOTE: We do not write the new sandbox package DB location to+    -- 'cabal.sandbox.config' here because 'configure -w' must not affect+    -- subsequent 'install' (for UI compatibility with non-sandboxed mode).      indexFile     <- tryGetIndexFilePath config     maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile@@ -274,57 +303,94 @@    -- Calls 'configureAction' to do the real work, so nothing special has to be   -- done to support sandboxes.-  useSandbox <- reconfigure verbosity distPref-                mempty [] globalFlags noAddSource (buildNumJobs buildExFlags)-                (const Nothing)+  (useSandbox, config) <- reconfigure verbosity distPref+                          mempty [] globalFlags noAddSource+                          (buildNumJobs buildFlags) (const Nothing)    maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity distPref buildFlags extraArgs+    build verbosity config distPref buildFlags extraArgs   -- | Actually do the work of building the package. This is separate from -- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke -- 'reconfigure' twice.-build :: Verbosity -> FilePath -> BuildFlags -> [String] -> IO ()-build verbosity distPref buildFlags extraArgs =+build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO ()+build verbosity config distPref buildFlags extraArgs =   setupWrapper verbosity setupOptions Nothing-               (Cabal.buildCommand progConf) (const buildFlags') extraArgs+               (Cabal.buildCommand progConf) mkBuildFlags extraArgs   where     progConf     = defaultProgramConfiguration     setupOptions = defaultSetupScriptOptions { useDistPref = distPref }-    buildFlags'  = buildFlags++    mkBuildFlags version = filterBuildFlags version config buildFlags'+    buildFlags' = buildFlags       { buildVerbosity = toFlag verbosity-      , buildDistPref = toFlag distPref+      , buildDistPref  = toFlag distPref       } +-- | Make sure that we don't pass new flags to setup scripts compiled against+-- old versions of Cabal.+filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags+filterBuildFlags version config buildFlags+  | version >= Version [1,19,1] [] = buildFlags_latest+  -- Cabal < 1.19.1 doesn't support 'build -j'.+  | otherwise                      = buildFlags_pre_1_19_1+  where+    buildFlags_pre_1_19_1 = buildFlags {+      buildNumJobs = NoFlag+      }+    buildFlags_latest     = buildFlags {+      -- Take the 'jobs' setting '~/.cabal/config' into account.+      buildNumJobs = Flag . Just . determineNumJobs $+                     (numJobsConfigFlag `mappend` numJobsCmdLineFlag)+      }+    numJobsConfigFlag  = installNumJobs . savedInstallFlags $ config+    numJobsCmdLineFlag = buildNumJobs buildFlags++ replAction :: ReplFlags -> [String] -> GlobalFlags -> IO () replAction replFlags extraArgs globalFlags = do-  let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                    (replDistPref replFlags)-      verbosity   = fromFlagOrDefault normal (replVerbosity replFlags)-      noAddSource = case replReload replFlags of-                      Flag True -> SkipAddSourceDepsCheck-                      _         -> DontSkipAddSourceDepsCheck+  cwd     <- getCurrentDirectory+  pkgDesc <- findPackageDesc cwd+  either (const onNoPkgDesc) (const onPkgDesc) pkgDesc+  where+    verbosity = fromFlagOrDefault normal (replVerbosity replFlags) -  -- Calls 'configureAction' to do the real work, so nothing special has to be-  -- done to support sandboxes.-  useSandbox <- reconfigure verbosity distPref-                mempty [] globalFlags noAddSource NoFlag-                (const Nothing)+    -- There is a .cabal file in the current directory: start a REPL and load+    -- the project's modules.+    onPkgDesc = do+      let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                        (replDistPref replFlags)+          noAddSource = case replReload replFlags of+                          Flag True -> SkipAddSourceDepsCheck+                          _         -> DontSkipAddSourceDepsCheck+          progConf     = defaultProgramConfiguration+          setupOptions = defaultSetupScriptOptions+            { useCabalVersion = orLaterVersion $ Version [1,18,0] []+            , useDistPref     = distPref+            }+          replFlags'   = replFlags+            { replVerbosity = toFlag verbosity+            , replDistPref  = toFlag distPref+            }+      -- Calls 'configureAction' to do the real work, so nothing special has to+      -- be done to support sandboxes.+      (useSandbox, _config) <- reconfigure verbosity distPref+                               mempty [] globalFlags noAddSource NoFlag+                               (const Nothing) -  maybeWithSandboxDirOnSearchPath useSandbox $-    let progConf     = defaultProgramConfiguration-        setupOptions = defaultSetupScriptOptions-          { useCabalVersion = orLaterVersion $ Version [1,18,0] []-          , useDistPref     = distPref-          }-        replFlags'   = replFlags-          { replVerbosity = toFlag verbosity-          , replDistPref  = toFlag distPref-          }-    in setupWrapper verbosity setupOptions Nothing-         (Cabal.replCommand progConf) (const replFlags') extraArgs+      maybeWithSandboxDirOnSearchPath useSandbox $+        setupWrapper verbosity setupOptions Nothing+        (Cabal.replCommand progConf) (const replFlags') extraArgs +    -- No .cabal file in the current directory: just start the REPL (possibly+    -- using the sandbox package DB).+    onNoPkgDesc = do+      (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+                               mempty+      let configFlags = savedConfigureFlags config+      (comp, _platform, programDb) <- configCompilerAux' configFlags+      startInterpreter verbosity programDb comp (configPackageDB' configFlags)  -- | Re-configure the package in the current directory if needed. Deciding -- when to reconfigure and with which options is convoluted:@@ -383,7 +449,7 @@                             -- prefix setting is always required, it is checked                             -- automatically; this function need not check                             -- for it.-            -> IO UseSandbox+            -> IO (UseSandbox, SavedConfig) reconfigure verbosity distPref     addConfigFlags extraArgs globalFlags             skipAddSourceDepsCheck numJobsFlag    checkFlags = do   eLbi <- tryGetPersistBuildConfig distPref@@ -397,7 +463,8 @@     --     -- 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+    onNoBuildConfig :: String -> ConfigStateFileErrorType+                       -> IO (UseSandbox, SavedConfig)     onNoBuildConfig err errCode = do       let msg = case errCode of             ConfigStateFileMissing    -> "Package has never been configured."@@ -411,15 +478,14 @@             $ msg ++ " Configuring with default flags." ++ configureManually           configureAction (defaultFlags, defaultConfigExFlags)             extraArgs globalFlags-      (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty-      return useSandbox+      loadConfigOrSandboxConfig verbosity globalFlags mempty      -- Package has been configured, but the configuration may be out of     -- date or required flags may not be set.     --     -- If we're in a sandbox: reinstall the modified add-source deps and     -- force reconfigure if we did.-    onBuildConfig :: LBI.LocalBuildInfo -> IO UseSandbox+    onBuildConfig :: LBI.LocalBuildInfo -> IO (UseSandbox, SavedConfig)     onBuildConfig lbi = do       let configFlags = LBI.configFlags lbi           flags       = mconcat [configFlags, addConfigFlags, distVerbFlags]@@ -436,14 +502,17 @@             | isSandboxConfigNewer = SkipAddSourceDepsCheck             | otherwise            = skipAddSourceDepsCheck -      (useSandbox, depsReinstalled) <-+      when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $+        info verbosity "Skipping add-source deps check..."++      (useSandbox, config, depsReinstalled) <-         case skipAddSourceDepsCheck' of         DontSkipAddSourceDepsCheck     ->           maybeReinstallAddSourceDeps verbosity numJobsFlag flags globalFlags         SkipAddSourceDepsCheck -> do-          (useSandbox, _) <- loadConfigOrSandboxConfig verbosity-                             globalFlags mempty-          return (useSandbox, NoDepsReinstalled)+          (useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                                  globalFlags (configUserInstall flags)+          return (useSandbox, config, NoDepsReinstalled)        -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need       -- to force reconfigure. Note that it's possible to use @cabal.config@@@ -460,22 +529,14 @@          -- No message for the user indicates that reconfiguration         -- is not required.-        Nothing -> return useSandbox+        Nothing -> return (useSandbox, config)          -- Show the message and reconfigure.         Just msg -> do           notice verbosity msg           configureAction (flags, defaultConfigExFlags)             extraArgs globalFlags-          return useSandbox--    -- True if the first file exists and is more recent than the second file.-    existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool-    existsAndIsMoreRecentThan a b = do-      exists <- doesFileExist a-      if not exists-        then return False-        else a `moreRecentFile` b+          return (useSandbox, config)      -- Determine what message, if any, to display to the user if reconfiguration     -- is required.@@ -576,11 +637,14 @@   let sandboxDistPref = case useSandbox of         NoSandbox             -> NoFlag         UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir-      configFlags'    = savedConfigureFlags   config `mappend` configFlags+      configFlags'    = maybeForceTests installFlags' $+                        savedConfigureFlags   config `mappend` configFlags       configExFlags'  = defaultConfigExFlags         `mappend`                         savedConfigureExFlags config `mappend` configExFlags       installFlags'   = defaultInstallFlags          `mappend`                         savedInstallFlags     config `mappend` installFlags+      haddockFlags'   = defaultHaddockFlags          `mappend`+                        savedHaddockFlags     config `mappend` haddockFlags       globalFlags'    = savedGlobalFlags      config `mappend` globalFlags   (comp, platform, conf) <- configCompilerAux' configFlags' @@ -615,15 +679,25 @@               comp platform conf               useSandbox mSandboxPkgInfo               globalFlags' configFlags'' configExFlags'-              installFlags' haddockFlags+              installFlags' haddockFlags'               targets -testAction :: (TestFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()-testAction (testFlags, buildExFlags) extraArgs globalFlags = do+    where+      -- '--run-tests' implies '--enable-tests'.+      maybeForceTests installFlags' configFlags' =+        if fromFlagOrDefault False (installRunTests installFlags')+        then configFlags' { configTests = toFlag True }+        else configFlags'++testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags+              -> IO ()+testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do   let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)       distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)                        (testDistPref testFlags)       setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+      buildFlags'    = buildFlags { buildVerbosity = testVerbosity testFlags+                                  , buildDistPref  = testDistPref testFlags }       addConfigFlags = mempty { configTests = toFlag True }       checkFlags flags         | fromFlagOrDefault False (configTests flags) = Nothing@@ -633,24 +707,30 @@    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  useSandbox <- reconfigure verbosity distPref addConfigFlags []-                globalFlags noAddSource (buildNumJobs buildExFlags) checkFlags+  (useSandbox, config) <- reconfigure verbosity distPref addConfigFlags []+                          globalFlags noAddSource+                          (buildNumJobs buildFlags') checkFlags    maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity distPref mempty extraArgs+    build verbosity config distPref buildFlags' extraArgs    maybeWithSandboxDirOnSearchPath useSandbox $     setupWrapper verbosity setupOptions Nothing       Cabal.testCommand (const testFlags) extraArgs -benchmarkAction :: (BenchmarkFlags, BuildExFlags) -> [String] -> GlobalFlags+benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)+                   -> [String] -> GlobalFlags                    -> IO ()-benchmarkAction (benchmarkFlags, buildExFlags) extraArgs globalFlags = do+benchmarkAction (benchmarkFlags, buildFlags, buildExFlags)+                extraArgs globalFlags = do   let verbosity      = fromFlagOrDefault normal                        (benchmarkVerbosity benchmarkFlags)       distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)                        (benchmarkDistPref benchmarkFlags)       setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+      buildFlags'    = buildFlags+        { buildVerbosity = benchmarkVerbosity benchmarkFlags+        , buildDistPref  = benchmarkDistPref  benchmarkFlags }       addConfigFlags = mempty { configBenchmarks = toFlag True }       checkFlags flags         | fromFlagOrDefault False (configBenchmarks flags) = Nothing@@ -660,22 +740,40 @@    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  useSandbox <- reconfigure verbosity distPref addConfigFlags []-                globalFlags noAddSource (buildNumJobs buildExFlags)-                checkFlags+  (useSandbox, config) <- reconfigure verbosity distPref addConfigFlags []+                          globalFlags noAddSource (buildNumJobs buildFlags')+                          checkFlags    maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity distPref mempty extraArgs+    build verbosity config distPref buildFlags' extraArgs    maybeWithSandboxDirOnSearchPath useSandbox $     setupWrapper verbosity setupOptions Nothing       Cabal.benchmarkCommand (const benchmarkFlags) extraArgs +haddockAction :: HaddockFlags -> [String] -> GlobalFlags -> IO ()+haddockAction haddockFlags extraArgs globalFlags = do+  let verbosity = fromFlag (haddockVerbosity haddockFlags)+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  let haddockFlags' = defaultHaddockFlags      `mappend`+                      savedHaddockFlags config `mappend` haddockFlags+      setupScriptOptions = defaultSetupScriptOptions {+        useDistPref = fromFlagOrDefault+                      (useDistPref defaultSetupScriptOptions)+                      (haddockDistPref haddockFlags')+        }+  setupWrapper verbosity setupScriptOptions Nothing+    haddockCommand (const haddockFlags') extraArgs+ listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do   let verbosity = fromFlag (listVerbosity listFlags)-  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty-  let configFlags  = savedConfigureFlags config+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  let configFlags' = savedConfigureFlags config+      configFlags  = configFlags' {+        configPackageDBs = configPackageDBs configFlags'+                           `mappend` listPackageDBs listFlags+        }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags   (comp, _, conf) <- configCompilerAux' configFlags   List.list verbosity@@ -690,8 +788,12 @@ infoAction infoFlags extraArgs globalFlags = do   let verbosity = fromFlag (infoVerbosity infoFlags)   targets <- readUserTargets verbosity extraArgs-  (_, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty-  let configFlags  = savedConfigureFlags config+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  let configFlags' = savedConfigureFlags config+      configFlags  = configFlags' {+        configPackageDBs = configPackageDBs configFlags'+                           `mappend` infoPackageDBs infoFlags+        }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags   (comp, _, conf) <- configCompilerAuxEx configFlags   List.info verbosity@@ -708,7 +810,7 @@   unless (null extraArgs) $     die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs   let verbosity = fromFlag verbosityFlag-  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags NoFlag+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty   let globalFlags' = savedGlobalFlags config `mappend` globalFlags   update verbosity (globalRepos globalFlags') @@ -741,6 +843,24 @@         comp platform conf globalFlags' fetchFlags         targets +freezeAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()+freezeAction freezeFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (freezeVerbosity freezeFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, conf) <- configCompilerAux' configFlags++  maybeWithSandboxPackageInfo verbosity configFlags globalFlags'+                              comp platform conf useSandbox $ \mSandboxPkgInfo ->+                              maybeWithSandboxDirOnSearchPath useSandbox $+      freeze verbosity+            (configPackageDB' configFlags)+            (globalRepos globalFlags')+            comp platform conf+            mSandboxPkgInfo+            globalFlags' freezeFlags+ uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () uploadAction uploadFlags extraArgs globalFlags = do   let verbosity = fromFlag (uploadVerbosity uploadFlags)@@ -780,6 +900,16 @@   allOk <- Check.check (fromFlag verbosityFlag)   unless allOk exitFailure +formatAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+formatAction verbosityFlag extraArgs _globalFlags = do+  let verbosity = fromFlag verbosityFlag+  path <- case extraArgs of+    [] -> do cwd <- getCurrentDirectory+             tryFindPackageDesc cwd+    (p:_) -> return p+  pkgDesc <- readPackageDescription verbosity path+  -- Uses 'writeFileAtomic' under the hood.+  writeGenericPackageDescription path pkgDesc  sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO () sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do@@ -811,15 +941,15 @@    -- reconfigure also checks if we're in a sandbox and reinstalls add-source   -- deps if needed.-  useSandbox <- reconfigure verbosity distPref mempty []-                globalFlags noAddSource (buildNumJobs buildExFlags)-                (const Nothing)+  (useSandbox, config) <- reconfigure verbosity distPref mempty []+                          globalFlags noAddSource (buildNumJobs buildFlags)+                          (const Nothing)    lbi <- getPersistBuildConfig distPref   (exe, exeArgs) <- splitRunArgs lbi extraArgs    maybeWithSandboxDirOnSearchPath useSandbox $-    build verbosity distPref mempty ["exe:" ++ exeName exe]+    build verbosity config distPref buildFlags ["exe:" ++ exeName exe]    maybeWithSandboxDirOnSearchPath useSandbox $     run verbosity lbi exe exeArgs@@ -843,7 +973,7 @@ initAction :: InitFlags -> [String] -> GlobalFlags -> IO () initAction initFlags _extraArgs globalFlags = do   let verbosity = fromFlag (initVerbosity initFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty   let configFlags  = savedConfigureFlags config   (comp, _, conf) <- configCompilerAux' configFlags   initCabal verbosity@@ -886,6 +1016,37 @@    where     noExtraArgs = (<1) . length++execAction :: ExecFlags -> [String] -> GlobalFlags -> IO ()+execAction execFlags extraArgs globalFlags = do+  let verbosity = fromFlag (execVerbosity execFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+                           mempty+  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+    -- 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 ++ ":" ++ g)]  -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. --

bootstrap.sh view

@@ -1,4 +1,4 @@-#!/bin/sh+#!/usr/bin/env sh  # A script to bootstrap cabal-install. @@ -12,19 +12,78 @@ #EXTRA_BUILD_OPTS #EXTRA_INSTALL_OPTS +die () { printf "\nError during cabal-install bootstrap:\n$1\n" >&2 && exit 2 ;}+ # programs, you can override these by setting environment vars-GHC=${GHC:-ghc}-GHC_PKG=${GHC_PKG:-ghc-pkg}-WGET=${WGET:-wget}-CURL=${CURL:-curl}-FETCH=${FETCH:-fetch}-TAR=${TAR:-tar}-GUNZIP=${GUNZIP:-gunzip}+GHC="${GHC:-ghc}"+GHC_PKG="${GHC_PKG:-ghc-pkg}"+GHC_VER="$(${GHC} --numeric-version)"+HADDOCK=${HADDOCK:-haddock}+WGET="${WGET:-wget}"+CURL="${CURL:-curl}"+FETCH="${FETCH:-fetch}"+TAR="${TAR:-tar}"+GZIP="${GZIP:-gzip}" SCOPE_OF_INSTALLATION="--user" DEFAULT_PREFIX="${HOME}/.cabal" +# Try to respect $TMPDIR but override if needed - see #1710.+[ -"$TMPDIR"- = -""- ] || echo "$TMPDIR" | grep -q ld &&+  export TMPDIR=/tmp/cabal-$(echo $(od -XN4 -An /dev/random)) && mkdir $TMPDIR -for arg in $*+# Check for a C compiler.+[ ! -x "$CC" ] && for ccc in gcc clang cc icc; do+  ${ccc} --version > /dev/null 2>&1 && CC=$ccc &&+  echo "Using $CC for C compiler. If this is not what you want, set CC." >&2 &&+  break+done++# None found.+[ ! -x `which "$CC"` ] &&+  die "C compiler not found (or could not be run).+       If a C compiler is installed make sure it is on your PATH,+       or set the CC variable."++# Check the C compiler/linker work.+LINK="$(for link in collect2 ld; do+  echo 'main;' | ${CC} -v -x c - -o /dev/null -\#\#\# 2>&1 | grep -q $link &&+  echo 'main;' | ${CC} -v -x c - -o /dev/null -\#\#\# 2>&1 | grep    $link |+  sed -e "s|\(.*$link\).*|\1|" -e 's/ //g' -e 's|"||' && break+done)"++# They don't.+[ -z "$LINK" ] &&+  die "C compiler and linker could not compile a simple test program.+       Please check your toolchain."++## Warn that were's overriding $LD if set (if you want).++[ -x "$LD" ] && [ "$LD" != "$LINK" ] &&+  echo "Warning: value set in $LD is not the same as C compiler's $LINK." >&2+  echo "Using $LINK instead." >&2++# Set LD, overriding environment if necessary.+LD=$LINK++# Check we're in the right directory, etc.+grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 ||+  die "The bootstrap.sh script must be run in the cabal-install directory"++${GHC} --numeric-version > /dev/null 2>&1  ||+  die "${GHC} not found (or could not be run).+       If ghc is installed,  make sure it is on your PATH,+       or set the GHC and GHC_PKG vars."++${GHC_PKG} --version     > /dev/null 2>&1  || die "${GHC_PKG} not found."++GHC_VER="$(${GHC} --numeric-version)"+GHC_PKG_VER="$(${GHC_PKG} --version | cut -d' ' -f 5)"++[ ${GHC_VER} = ${GHC_PKG_VER} ] ||+  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     "--user")@@ -34,6 +93,9 @@       SCOPE_OF_INSTALLATION=${arg}       DEFAULT_PREFIX="/usr/local"       shift;;+    "--no-doc")+      NO_DOCUMENTATION=1+      shift;;     *)       echo "Unknown argument or option, quitting: ${arg}"       echo "usage: bootstrap.sh [OPTION]"@@ -41,54 +103,52 @@       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"       exit;;   esac done +# Check for haddock unless no documentation should be generated.+if [ ! ${NO_DOCUMENTATION} ]+then+  ${HADDOCK} --version     > /dev/null 2>&1  || die "${HADDOCK} not found."+fi+ PREFIX=${PREFIX:-${DEFAULT_PREFIX}}  # 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]\."         # >= 1.1 && < 2-TEXT_VER="1.1.0.0";    TEXT_VER_REGEXP="((1\.[01]\.)|(0\.([2-9]|(1[0-1]))\.))" # >= 0.2 && < 1.2-NETWORK_VER="2.6.0.2"; NETWORK_VER_REGEXP="2\."                # == 2.*-CABAL_VER="1.18.1.7";  CABAL_VER_REGEXP="1\.1[89]\."           # >= 1.18 && < 1.20-TRANS_VER="0.3.0.0";   TRANS_VER_REGEXP="0\.[23]\."            # >= 0.2.* && < 0.4.*-MTL_VER="2.1.2";       MTL_VER_REGEXP="[2]\."                  #  == 2.*-HTTP_VER="4000.2.16.1";  HTTP_VER_REGEXP="4000\.[012]\."         # == 4000.0.* || 4000.1.* || 4000.2.*-ZLIB_VER="0.5.4.1";    ZLIB_VER_REGEXP="0\.[45]\."             # == 0.4.* || == 0.5.*-TIME_VER="1.4.1";      TIME_VER_REGEXP="1\.[12345]\.?"         # >= 1.1 && < 1.6-RANDOM_VER="1.0.1.1";  RANDOM_VER_REGEXP="1\.0\."              # >= 1 && < 1.1-STM_VER="2.4.2";       STM_VER_REGEXP="2\."                    # == 2.*-NETWORK_URI_VER="2.6.0.1"; NETWORK_URI_VER_REGEXP="2\.[6-9]\." # >= 2.6--HACKAGE_URL="http://hackage.haskell.org/packages/archive"--die () {-  echo-  echo "Error during cabal-install bootstrap:"-  echo $1 >&2-  exit 2-}--# Check we're in the right directory:-grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 \-  || die "The bootstrap.sh script must be run in the cabal-install directory"+PARSEC_VER="3.1.5";    PARSEC_VER_REGEXP="[23]\."+                       # == 2.* || == 3.*+DEEPSEQ_VER="1.3.0.2"; 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.0";  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]"+                       # >= 4000.2.5 < 4000.3+ZLIB_VER="0.5.4.1";    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\."+                       # == 2.* -${GHC} --numeric-version > /dev/null \-  || die "${GHC} not found (or could not be run). If ghc is installed make sure it is on your PATH or set the GHC and GHC_PKG vars."-${GHC_PKG} --version     > /dev/null \-  || die "${GHC_PKG} not found."-GHC_VER=`${GHC} --numeric-version`-GHC_PKG_VER=`${GHC_PKG} --version | cut -d' ' -f 5`-[ ${GHC_VER} = ${GHC_PKG_VER} ] \-  || die "Version mismatch between ${GHC} and ${GHC_PKG} If you set the GHC variable then set GHC_PKG too"+HACKAGE_URL="https://hackage.haskell.org/package"  # Cache the list of packages: echo "Checking installed packages for ghc-${GHC_VER}..."-${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list \-  || die "running '${GHC_PKG} list' failed"+${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list ||+  die "running '${GHC_PKG} list' failed"  # Will we need to install this package, or is a suitable version installed? need_pkg () {@@ -120,10 +180,13 @@   PKG=$1   VER=$2 -  URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz+  URL=${HACKAGE_URL}/${PKG}-${VER}/${PKG}-${VER}.tar.gz   if which ${CURL} > /dev/null   then-    ${CURL} -L --fail -C - -O ${URL} || die "Failed to download ${PKG}."+    # TODO: switch back to resuming curl command once+    #       https://github.com/haskell/hackage-server/issues/111 is resolved+    #${CURL} -L --fail -C - -O ${URL} || die "Failed to download ${PKG}."+    ${CURL} -L --fail -O ${URL} || die "Failed to download ${PKG}."   elif which ${WGET} > /dev/null   then     ${WGET} -c ${URL} || die "Failed to download ${PKG}."@@ -133,21 +196,17 @@   else     die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required."   fi-  [ -f "${PKG}-${VER}.tar.gz" ] \-    || die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz"+  [ -f "${PKG}-${VER}.tar.gz" ] ||+     die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz" }  unpack_pkg () {   PKG=$1   VER=$2 -  rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"/-  ${GUNZIP} -f "${PKG}-${VER}.tar.gz" \-    || die "Failed to gunzip ${PKG}-${VER}.tar.gz"-  ${TAR} -xf "${PKG}-${VER}.tar" \-    || die "Failed to untar ${PKG}-${VER}.tar.gz"-  [ -d "${PKG}-${VER}" ] \-    || die "Unpacking ${PKG}-${VER}.tar.gz did not create ${PKG}-${VER}/"+  rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"+  ${GZIP} -d < "${PKG}-${VER}.tar.gz" | ${TAR} -x+  [ -d "${PKG}-${VER}" ] || die "Failed to unpack ${PKG}-${VER}.tar.gz" }  install_pkg () {@@ -156,20 +215,28 @@   [ -x Setup ] && ./Setup clean   [ -f Setup ] && rm Setup -  ${GHC} --make Setup -o Setup \-    || die "Compiling the Setup script failed"+  ${GHC} --make Setup -o Setup ||+    die "Compiling the Setup script failed."+   [ -x Setup ] || die "The Setup script does not exist or cannot be run" -  ./Setup configure ${SCOPE_OF_INSTALLATION} "--prefix=${PREFIX}" \-    --with-compiler=${GHC} --with-hc-pkg=${GHC_PKG} \-    ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \-    || die "Configuring the ${PKG} package failed"+  args="${SCOPE_OF_INSTALLATION} --prefix=${PREFIX} --with-compiler=${GHC}"+  args="$args --with-hc-pkg=${GHC_PKG} --with-gcc=${CC} --with-ld=${LD}"+  args="$args ${EXTRA_CONFIGURE_OPTS} ${VERBOSE}" -  ./Setup build ${EXTRA_BUILD_OPTS} ${VERBOSE} \-    || die "Building the ${PKG} package failed"+  ./Setup configure $args || die "Configuring the ${PKG} package failed." -  ./Setup install ${SCOPE_OF_INSTALLATION} ${EXTRA_INSTALL_OPTS} ${VERBOSE} \-    || die "Installing the ${PKG} package failed"+  ./Setup build ${EXTRA_BUILD_OPTS} ${VERBOSE} ||+     die "Building the ${PKG} package failed."++  if [ ! ${NO_DOCUMENTATION} ]+  then+    ./Setup haddock --with-ghc=${GHC} --with-haddock=${HADDOCK} ${VERBOSE} ||+      die "Documenting the ${PKG} package failed."+  fi++  ./Setup install ${SCOPE_OF_INSTALLATION} ${EXTRA_INSTALL_OPTS} ${VERBOSE} ||+     die "Installing the ${PKG} package failed." }  do_pkg () {@@ -189,25 +256,6 @@   fi } -# Replicate the flag selection logic for network-uri in the .cabal file.-do_network_uri_pkg () {-  # Refresh installed package list.-  ${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg-stage2.list \-    || die "running '${GHC_PKG} list' failed"--  NETWORK_URI_DUMMY_VER="2.5.0.0"; NETWORK_URI_DUMMY_VER_REGEXP="2\.5\." # < 2.6-  if egrep " network-2\.[6-9]\." ghc-pkg-stage2.list > /dev/null 2>&1-  then-    # Use network >= 2.6 && network-uri >= 2.6-    info_pkg "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}-    do_pkg   "network-uri" ${NETWORK_URI_VER} ${NETWORK_URI_VER_REGEXP}-  else-    # Use network < 2.6 && network-uri < 2.6-    info_pkg "network-uri" ${NETWORK_URI_DUMMY_VER} ${NETWORK_URI_DUMMY_VER_REGEXP}-    do_pkg   "network-uri" ${NETWORK_URI_DUMMY_VER} ${NETWORK_URI_DUMMY_VER_REGEXP}-  fi-}- # Actually do something!  info_pkg "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP}@@ -231,10 +279,6 @@ do_pkg   "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP} do_pkg   "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP} do_pkg   "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}--# We conditionally install network-uri, depending on the network version.-do_network_uri_pkg- do_pkg   "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP} do_pkg   "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP} do_pkg   "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP}

cabal-install.cabal view

@@ -1,5 +1,5 @@ Name:               cabal-install-Version:            1.18.2.0+Version:            1.20.0.0 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -34,10 +34,6 @@   description:  Use directory < 1.2 and old-time   default:      False -flag network-uri-  description: Get Network.URI from the network-uri package-  default: True- executable cabal     main-is:        Main.hs     ghc-options:    -Wall -fwarn-tabs@@ -75,6 +71,7 @@         Distribution.Client.Dependency.Modular.Version         Distribution.Client.Fetch         Distribution.Client.FetchUtils+        Distribution.Client.Freeze         Distribution.Client.Get         Distribution.Client.GZipUtils         Distribution.Client.Haddock@@ -110,7 +107,9 @@         Distribution.Client.World         Distribution.Client.Win32SelfUpgrade         Distribution.Client.Compat.Environment+        Distribution.Client.Compat.ExecutablePath         Distribution.Client.Compat.FilePerms+        Distribution.Client.Compat.Process         Distribution.Client.Compat.Semaphore         Distribution.Client.Compat.Time         Paths_cabal_install@@ -119,18 +118,18 @@     -- in bootstrap.sh.     build-depends:         array      >= 0.1      && < 0.6,-        base       >= 4        && < 4.8,+        base       >= 4.3      && < 5,         bytestring >= 0.9      && < 1,-        Cabal      >= 1.18.0   && < 1.19,+        Cabal      >= 1.20.0   && < 1.21,         containers >= 0.1      && < 0.6,         filepath   >= 1.0      && < 1.4,-        HTTP       >= 4000.0.8 && < 4001,+        HTTP       >= 4000.2.5 && < 4000.3,         mtl        >= 2.0      && < 3,-        network    >= 1        && < 3,+        network    >= 2.0      && < 2.6,         pretty     >= 1        && < 1.2,-        random     >= 1        && < 1.2,+        random     >= 1        && < 1.1,         stm        >= 2.0      && < 3,-        time       >= 1.1      && < 1.6,+        time       >= 1.1      && < 1.5,         zlib       >= 0.5.3    && < 0.6      if flag(old-directory)@@ -140,11 +139,6 @@       build-depends: directory >= 1.2 && < 1.3,                      process   >= 1.1.0.2  && < 1.3 -    if flag(network-uri)-      build-depends: network-uri >= 2.6, network >= 2.6-    else-      build-depends: network-uri < 2.6, network < 2.6-     if os(windows)       build-depends: Win32 >= 2 && < 3       cpp-options: -DWIN32@@ -152,7 +146,7 @@       build-depends: unix >= 2.0 && < 2.8      if arch(arm) && impl(ghc < 7.6)-       -- older ghc on arm does not supprt -threaded+       -- older ghc on arm does not support -threaded        cc-options:  -DCABAL_NO_THREADED     else        ghc-options: -threaded@@ -176,12 +170,14 @@         Cabal,         containers,         mtl,+        network,         pretty,         process,         directory,         filepath,         stm,         time,+        network,         HTTP,         zlib, @@ -193,11 +189,6 @@    if flag(old-directory)     build-depends: old-time--  if flag(network-uri)-    build-depends: network-uri >= 2.6, network >= 2.6-  else-    build-depends: network-uri < 2.6, network < 2.6    if os(windows)     build-depends: Win32